diff --git a/.gitignore b/.gitignore index 6375f2bc5..36f897261 100644 --- a/.gitignore +++ b/.gitignore @@ -16,6 +16,7 @@ config.h *.x *.lo *.la +*.exe aclocal.m4 libtool ltmain.sh @@ -142,6 +143,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 @@ -163,3 +165,6 @@ INSTALL /libguile/vm-operations.h /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/.gnuploadrc b/.gnuploadrc deleted file mode 100644 index 29acf7312..000000000 --- a/.gnuploadrc +++ /dev/null @@ -1 +0,0 @@ ---user ludo@gnu.org 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. diff --git a/GNUmakefile b/GNUmakefile index 4ab642943..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-2014 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/GUILE-VERSION b/GUILE-VERSION index 4a3f4fcef..223a2935f 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=0 +GUILE_MINOR_VERSION=2 +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=0 +LIBGUILE_INTERFACE_CURRENT=3 LIBGUILE_INTERFACE_REVISION=0 -LIBGUILE_INTERFACE_AGE=0 +LIBGUILE_INTERFACE_AGE=2 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" diff --git a/HACKING b/HACKING index b08f7c2d4..181530fd4 100644 --- a/HACKING +++ b/HACKING @@ -1,6 +1,6 @@ -*-text-*- Guile Hacking Guide -Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008, 2012 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 @@ -20,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 ================================================== @@ -69,7 +64,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. @@ -77,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 ============================================ @@ -178,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 @@ -224,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, @@ -265,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. @@ -324,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 - diff --git a/Makefile.am b/Makefile.am index 8f9e014c7..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 Free Software Foundation, Inc. +## 2014, 2015, 2016 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -30,6 +30,7 @@ SUBDIRS = \ lib \ meta \ libguile \ + bootstrap \ module \ guile-readline \ examples \ @@ -40,6 +41,8 @@ SUBDIRS = \ am \ doc +DIST_SUBDIRS = $(SUBDIRS) prebuilt + libguileincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION) libguileinclude_HEADERS = libguile.h @@ -88,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/ @@ -105,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 $@ diff --git a/NEWS b/NEWS index 208ec9ebd..7ce583b9b 100644 --- a/NEWS +++ b/NEWS @@ -1,12 +1,149 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2015 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. -Changes in 2.1.1 (changes since the 2.0.x series): +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". + +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): + +* 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. + +** 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): + +* 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 +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. +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. + +* 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): * Notable changes @@ -21,9 +158,9 @@ 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. +See "Scheduling" in the manual, for updated documentation on threads and +communications primitives. ** Better space-safety @@ -55,14 +192,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 @@ -101,6 +238,40 @@ 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. + +** 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. + +** Lightweight pre-emptive threading primitives + +The compiler now inserts special "handle-interrupts" opcodes before each +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 + +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 lightweight fiber. + * Performance improvements ** Faster programs via new virtual machine @@ -132,10 +303,11 @@ 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, unboxing of 64-bit +integers and floating point values, and closure optimization. For more, +see "Continuation-Passing Style" in the manual. ** Faster interpreter @@ -169,6 +341,20 @@ 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. + +** 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' @@ -185,29 +371,55 @@ 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' +** Add "tree" display mode for statprof. -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. +See "Non-Blocking I/O" in the manual, for more. -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!', +** Implement R6RS custom binary input/output ports -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 "Custom Ports" in the manual. + +** Implement R6RS output-buffer-mode +** Implement R6RS bytevector->string, string->bytevector + +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. + +** 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 +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 "Asyncs" in the manual for more. + +** File descriptor finalizers + +See "Ports and File Descriptors" in the manual. ** New inline functions: `scm_new_smob', `scm_new_double_smob' @@ -224,14 +436,22 @@ 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 +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 @@ -264,6 +484,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 @@ -285,6 +596,122 @@ 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. + +** 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 +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 +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 @@ -351,6 +778,37 @@ 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. + +** 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 @@ -472,6 +930,62 @@ 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, +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 +ago that didn't survive the test of time. Use mutexes or atomic boxes +instead. + +** 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. + ** 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 @@ -524,6 +1038,19 @@ 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. + ** New minor version The "effective version" of Guile is now 2.2, which allows parallel @@ -533,6 +1060,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 @@ -540,6 +1076,277 @@ longer installed to the libdir. This change should be transparent to users, but packagers may be interested. + +Changes in 2.0.14 (since 2.0.13): + +* Bug fixes + +** 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 +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. + +* 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): + +* 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: + + - 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) + (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? + () +*** Skip invalid .go files found in GUILE_LOAD_COMPILED_PATH + +** 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 +*** 'open-pipe' 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): 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. diff --git a/README b/README index 92d786c06..575ea5c3b 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. @@ -401,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. @@ -413,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 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 diff --git a/THANKS b/THANKS index d5e8222fb..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 @@ -199,6 +201,7 @@ For fixes or providing information which led to a fix: Jon Wilson Andy Wingo Keith Wright + Ricardo Wurmus William Xu Atom X Zane 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]) diff --git a/am/bootstrap.am b/am/bootstrap.am new file mode 100644 index 000000000..e0d4764f5 --- /dev/null +++ b/am/bootstrap.am @@ -0,0 +1,155 @@ +## 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/build-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/handle-interrupts.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/ports.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/am/guilec b/am/guilec index 5ef07faa4..fa2054eeb 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) @@ -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/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/bootstrap/Makefile.am b/bootstrap/Makefile.am new file mode 100644 index 000000000..496d5301a --- /dev/null +++ b/bootstrap/Makefile.am @@ -0,0 +1,31 @@ +## 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 + + +GUILE_WARNINGS = +GUILE_OPTIMIZATIONS = -O1 + +include $(top_srcdir)/am/bootstrap.am + +# We must build the evaluator first, so that we can be sure to control +# the stack. +$(filter-out ice-9/eval.go, $(GOBJECTS)): ice-9/eval.go diff --git a/build-aux/announce-gen b/build-aux/announce-gen index db9ed50a7..e789b13a8 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-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 @@ -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..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-2014 Free Software Foundation, Inc. +# Copyright 1996-2017 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..3b71b36a2 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-12-31.18 -# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 -# 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 @@ -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 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." @@ -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..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=2012-12-31.23; # UTC +scriptversion=2017-01-09.19; # UTC -# Copyright (C) 2007-2014 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 @@ -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 @@ -205,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= @@ -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..cf1642546 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-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,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..a8ed60952 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-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 @@ -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..d4d95ee9b 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-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 @@ -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..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-2014 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 67b12335d..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-2014 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/unused-parameter.h b/build-aux/snippet/unused-parameter.h deleted file mode 100644 index 41d9510ca..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-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 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/build-aux/snippet/warn-on-use.h b/build-aux/snippet/warn-on-use.h index 1c4d7bd4e..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-2014 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 4c76c75d7..4e3f3a265 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-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-2014 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 @@ -202,6 +205,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..2d17eaf69 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-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 @@ -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/configure.ac b/configure.ac index 19e00d818..374b4297a 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, 2017 Free Software Foundation, Inc. This file is part of GUILE @@ -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) @@ -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 @@ -83,7 +95,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 @@ -313,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) @@ -617,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 @@ -715,7 +741,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, @@ -752,21 +778,22 @@ 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 # 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 \ - readdir_r readdir64_r readlink rename rmdir setegid seteuid \ - setlocale setpgid setsid sigaction siginterrupt stat64 \ + gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mknod nice \ + 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 \ 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]) + index bcopy memcpy rindex truncate isblank _NSGetEnviron \ + strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat \ + sched_getaffinity sched_setaffinity sendfile]) # Reasons for testing: # netdb.h - not in mingw @@ -865,6 +892,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 @@ -890,6 +968,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.]) @@ -1124,14 +1209,15 @@ 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 # 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. @@ -1246,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" @@ -1256,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" @@ -1643,12 +1733,19 @@ AC_CONFIG_FILES([ test-suite/standalone/Makefile test-suite/vm/Makefile 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]) +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/gendocs_template b/doc/gendocs_template index 4836df787..178f6cb4c 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..112fa3bfb --- /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 © 2017 Free Software Foundation, Inc.

+ +

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

+ + + + + + 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 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 diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 83c6e5ee0..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 \ @@ -120,7 +119,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/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 diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi deleted file mode 100644 index 8ec32d687..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 3@cross{}3 matrix with index ranges 0..2 -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. - -@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! name 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 orderedq 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 - -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-control.texi b/doc/ref/api-control.texi index 4253a206a..2d696ea89 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 @@ -168,7 +170,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 +180,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 @@ -584,10 +586,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. @@ -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 @@ -896,7 +923,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 @@ -1660,6 +1687,339 @@ 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 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 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. 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 +@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) +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-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. +@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) +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 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. 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) +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 + +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)) +(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 extent +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. 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 @@ -1801,8 +2161,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 3f787b1c9..7b10d34f4 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,42 +1,16 @@ @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-2016 @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 @@ -434,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) @@ -470,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) @@ -1712,7 +1702,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 @@ -2014,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 @@ -4579,470 +4569,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 of the -R6RS (@pxref{R6RS I/O Ports}). - -@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 - -@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 @@ -5135,7 +4661,7 @@ mapping consistently: @lisp ;; 1=red, 2=green, 3=purple -(if (eq? (colour-of car) 1) +(if (eq? (colour-of vehicle) 1) ...) @end lisp @@ -5148,7 +4674,7 @@ defining constants: (define green 2) (define purple 3) -(if (eq? (colour-of car) red) +(if (eq? (colour-of vehicle) red) ...) @end lisp @@ -5157,7 +4683,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 @@ -5179,15 +4705,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 @@ -5882,13 +5408,13 @@ 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. @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. @@ -6037,26 +5563,4670 @@ 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} 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 +@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:: +* Arrays as arrays of 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 Arrays as arrays of arrays +@subsubsection Arrays as arrays of arrays + +@cindex array cell + +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'). + +@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-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-cell-ref 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 + +@end deffn + +@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-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-slice a 1 1) 'b) +a @result{} #2((a a) (a b)). +(array-fill! (array-cell-ref a 1 1) 'b) @result{} error: not an array +@end lisp + +@code{(apply array-slice 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-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 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 +@var{array} and the dimensions of @var{x} must match exactly. + +This function returns the modified @var{array}. + +For example: + +@lisp +(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-cell-set!} will expect elements, not arrays, when +the destination has rank 0. Use @code{array-slice} for the opposite +behavior. + +@lisp +(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-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-cell-ref array indices))) + array) +@end lisp + +@end deffn + + +@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-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-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-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-element vector @math{(x,y)}. Let's compute the arguments of these +vectors and store them in rank-1 array @code{b}. +@lisp +(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-slice-for-each frame-rank op x)} is 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-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 + +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/api-debug.texi b/doc/ref/api-debug.texi index bf25c74c9..a6cfd7b03 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 @@ -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]] @@ -1088,11 +1104,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 +1118,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 +1151,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 +1180,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 +1189,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/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 296f1da5a..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 @@ -136,6 +137,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 +155,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 @@ -1225,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/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index c2c49ec48..bb93d6d1f 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-2017 +@c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Foreign Function Interface @@ -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 @@ -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 @@ -488,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 @@ -813,8 +820,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 +835,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/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/doc/ref/api-io.texi b/doc/ref/api-io.texi index e1501e2b4..9bd78d229 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1,24 +1,27 @@ @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 @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. -* 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. +* 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. @end menu @@ -27,66 +30,67 @@ @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}). 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. +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: -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}.) +@example +(let ((port (open-output-file "foo.txt"))) + (display "Hello, world!\n" port) + (close-port port)) +@end example -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. +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}. -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. +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. -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. +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. -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. +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: -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. +@example +(call-with-output-file "foo.txt" + (lambda (port) + (display "Hello, world!\n" port))) +@end example -Currently, the ports only work with @emph{non-modal} encodings. Most -encodings are non-modal, meaning that the conversion of bytes to a -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. +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. -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. +@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 @@ -104,184 +108,542 @@ Return @code{#t} if @var{x} is an output port, otherwise return @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}))}. +@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 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}. +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 @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. +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 -@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 +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. -@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. +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. -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 +Currently, the ports only work with @emph{non-modal} encodings. Most +encodings are non-modal, meaning that the conversion of bytes to a +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. + +@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. @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 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}. 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 @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}. -[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}. +@node Textual I/O +@subsection Textual I/O +@cindex textual input +@cindex textual output -@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}. +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. +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. -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. -@end deffn - -@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}, 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. -@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 +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. + +@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. + +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 + +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}. +@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) +@deffnx {C Function} scm_set_port_line_x (port, line) +Set the current column or line number of @var{port}. +@end deffn + +@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 +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 + +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 +@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 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 +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 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 +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 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. + +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. + +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 @@ -294,145 +656,13 @@ contents of the buffers are returned as a single string, e.g., (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 -@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 - -@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) -@deffnx {C Function} scm_set_port_line_x (port, line) -Set the current column or line number of @var{port}. -@end deffn - -@node Writing -@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}. - -@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 - -@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 - -@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 - -@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. 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 +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 @@ -509,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 @@ -534,26 +761,21 @@ 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!") @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!") @@ -571,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 @@ -642,106 +822,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 @@ -782,7 +862,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 @@ -806,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) @@ -824,12 +912,12 @@ 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. +* 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 @@ -843,6 +931,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}). @@ -882,8 +974,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. @@ -897,8 +988,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. @@ -919,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 @@ -1032,7 +1103,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 @@ -1050,21 +1121,45 @@ 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 + +@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 @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 @@ -1118,22 +1213,114 @@ 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 + +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 +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! + #f)) + +(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 +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 + +@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 @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 @@ -1198,1223 +1385,446 @@ 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 +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. -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. +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}. -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. +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. -@c FIXME: Update description when implemented. -@emph{Note}: The implementation of this R6RS API is not complete yet. +@rnindex char-ready? +@deffn {Scheme Procedure} char-ready? [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}. -@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 +@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. -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. +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}. -@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 +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 -@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] +The same as @code{get-char}, except that @var{port} defaults to the +current input port. @xref{Textual I/O}. @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] +The same as @code{lookahead-char}, except that @var{port} defaults to +the current input port. @xref{Textual I/O}. @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] +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 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) +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 -@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] +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 -@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] +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 -@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{Ports and File Descriptors, -@code{setvbuf}}). - -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 + +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 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 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} 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 -@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 +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 +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}, +or @code{scm_c_make_port_with_encoding}. -@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 - -@cindex ptob -@tindex scm_ptob_descriptor -@tindex scm_port -@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. - -@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. - -@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. - -The special treatment must be performed if the @code{rw_random} flag in -the port is non-zero. - -@subsubheading The @code{rw_active} variable - -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_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 +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. +@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. @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 -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 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 +@item read +A port's @code{read} implementation fills read buffers. It should copy +bytes to the supplied bytevector @code{dst}, starting at offset +@code{start} and continuing for @code{count} bytes, returning the number +of bytes read. -@deftypefun void scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM port)) -@end deftypefun +@item write +A port's @code{write} implementation flushes write buffers to the +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 free -Called when the port is collected during gc. It -should free any resources used by the port. +@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_free (scm_t_bits tc, size_t (*free) (SCM port)) +@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 -@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 +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. -@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 +@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 +like: @code{#}. Set using + +@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 -@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, 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)) +@deftypefun void scm_set_port_close (scm_t_port_type *type, void (*close) (SCM port)) @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}. +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. -@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)) +@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. 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: +Set the current position of the port. Guile will flush read and/or +write buffers before seeking, as appropriate. -@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 - -@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. 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)) +@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 +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_port_type *type, 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_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 + +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 +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 + +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 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. + +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}). + +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-modules (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 -@subsection Handling of Unicode byte order marks. +@subsection Handling of Unicode Byte Order Marks @cindex BOM @cindex byte order mark @@ -2475,7 +1885,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} diff --git a/doc/ref/api-languages.texi b/doc/ref/api-languages.texi index fb42987d9..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 @@ -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)) diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index 9964e6b06..7fa62e3d6 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 @@ -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/doc/ref/api-memory.texi b/doc/ref/api-memory.texi index 0e37d16fc..ce0187b14 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. @@ -27,24 +27,26 @@ 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}) 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. 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 @@ -309,10 +315,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 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. diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index b09ae8952..0259b4b21 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. @@ -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/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 diff --git a/doc/ref/api-regex.texi b/doc/ref/api-regex.texi index 082fb874d..b14c2b39c 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 @@ -41,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 diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 0d036be9e..7b39a03d6 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -8,189 +8,17 @@ @section Threads, Mutexes, Asyncs and Dynamic Roots @menu -* Arbiters:: Synchronization primitives. -* Asyncs:: Asynchronous procedure invocation. * Threads:: Multiple threads of execution. +* Thread Local Variables:: Some fluids are thread-local. +* Asyncs:: Asynchronous interrupts. +* 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. * Parallel Forms:: Parallel execution of forms. @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 - -@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. - -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 - -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. - -Analogously, the procedure @code{call-with-unblocked-asyncs} will -temporarily decrease the blocking level of the current thread. You -can use it when you want to disable asyncs by default and only allow -them temporarily. - -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. - -@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. - -This procedure is not safe to be called from 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 -arguments; for the third, call it with @var{data}. -@end deffn - -@deftypefn {C Function} {void *} scm_c_call_with_blocked_asyncs (void * (*proc) (void *data), void *data) -The same but with a C function @var{proc} instead of a Scheme thunk. -@end deftypefn - -@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}. -@end deffn - -@deftypefn {C Function} {void *} scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) -The same but with a C function @var{proc} instead of a Scheme thunk. -@end deftypefn - -@deftypefn {C Function} void scm_dynwind_block_asyncs () -During the current dynwind context, increase the blocking of asyncs by -one level. This function must be used inside a pair of calls to -@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic -Wind}). -@end deftypefn - -@deftypefn {C Function} void scm_dynwind_unblock_asyncs () -During the current dynwind context, decrease the blocking of asyncs by -one level. This function must be used inside a pair of calls to -@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic -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 Threads @subsection Threads @cindex threads @@ -207,6 +35,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. @@ -217,7 +51,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 @@ -251,17 +84,18 @@ 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 +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 @@ -270,52 +104,25 @@ 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 +@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 -@deffn {Scheme Procedure} cancel-thread thread +@deffn {Scheme Procedure} cancel-thread thread . values @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. Calling @code{join-thread} on the thread will +return the given @var{values}, if the cancel succeeded. -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 the 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 -@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 @@ -329,49 +136,418 @@ 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 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''. + +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 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 %thread-local (make-thread-local-fluid)) + +(with-fluids ((%thread-local (compute-data))) + ... (fluid-ref %thread-local) ...) +@end example + +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 +@subsection Asynchronous Interrupts + +@cindex asyncs +@cindex asynchronous interrupts +@cindex interrupts + +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. + +@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 + +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.) + +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. + +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 +can use it when you want to disable asyncs by default and only allow +them temporarily. + +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 asyncs temporarily. + +@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 +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_blocked_asyncs (void * (*proc) (void *data), void *data) +The same but with a C function @var{proc} instead of a Scheme thunk. +@end deftypefn + +@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 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) +The same but with a C function @var{proc} instead of a Scheme thunk. +@end deftypefn + +@deftypefn {C Function} void scm_dynwind_block_asyncs () +During the current dynwind context, increase the blocking of asyncs by +one level. This function must be used inside a pair of calls to +@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic +Wind}). +@end deftypefn + +@deftypefn {C Function} void scm_dynwind_unblock_asyncs () +During the current dynwind context, decrease the blocking of asyncs by +one level. This function must be used inside a pair of calls to +@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic +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, +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 + +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 Mutexes and Condition Variables @subsection Mutexes and Condition Variables @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 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 +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 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 +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. + +@example +(use-modules (ice-9 threads)) +@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 @@ -383,40 +559,32 @@ 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]] +@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 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 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) @@ -426,31 +594,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 @@ -497,12 +652,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 @@ -515,13 +669,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{}, @@ -596,361 +745,21 @@ 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 -@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 system 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. - -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 - -@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, 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. - -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. - -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} 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; -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 the current 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 @@ -1037,13 +846,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/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. diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 9743c5357..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 @@ -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,187 @@ 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, 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. + +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; 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 ``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)) +@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 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 +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. Updating an intmap is O(log +@var{n}) in the size of the intmap. + +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) + (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 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. + +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. + +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 @@ -915,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 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. diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index bc33ce080..a18984f31 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 @@ -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 @@ -176,7 +172,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 +180,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/doc/ref/guile.texi b/doc/ref/guile.texi index 5f21188fa..4bc3b74d8 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, 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 @@ -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/libguile-concepts.texi b/doc/ref/libguile-concepts.texi index 9e2eb7503..34010eebf 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,28 +197,44 @@ 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 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 @@ -402,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/misc-modules.texi b/doc/ref/misc-modules.texi index c1e65d7e3..6c899a905 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 @@ -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 @@ -106,7 +109,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 +207,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 +245,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 +763,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 +819,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 +1116,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 +1665,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/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}. diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 356941f2d..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 @@ -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}. @@ -299,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 @@ -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, @@ -431,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) @@ -455,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: - -@defvar _IONBF -non-buffered -@end defvar -@defvar _IOLBF -line buffered -@end defvar -@defvar _IOFBF -block buffered, using a newly allocated buffer of @var{size} bytes. -If @var{size} is omitted, a default size will be used. -@end defvar - -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. @@ -568,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. @@ -598,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 @@ -864,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 @@ -966,7 +973,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 @@ -987,6 +994,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 @@ -1966,29 +1977,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 @@ -1997,11 +1987,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) @@ -2087,6 +2077,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. @@ -2156,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 @@ -2170,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 @@ -2190,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 @@ -2249,7 +2262,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)) @@ -2278,7 +2291,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 @@ -2286,11 +2299,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 @@ -2333,8 +2345,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 @@ -3057,7 +3069,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 @@ -3191,6 +3203,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 @@ -3217,10 +3238,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) @@ -3261,18 +3284,33 @@ 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. 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). + +@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 diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index e5ffb78e4..fa8d7d213 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. @@ -722,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 @@ -1343,7 +1349,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 +1426,548 @@ 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 +@deffnx {Scheme Procedure} make-custom-binary-input/output-port id read! 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 +1984,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 +2006,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 +2015,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 +2032,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/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/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}. diff --git a/doc/ref/scheme-scripts.texi b/doc/ref/scheme-scripts.texi index 7552dba33..221c8ba20 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,79 @@ $ ./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. + +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" diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 4422c1863..ac265fcca 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] @@ -341,10 +345,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. @@ -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 diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index c890d7dd1..3d4415629 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 @@ -1823,8 +1824,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 @@ -1834,9 +1835,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 +1895,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 @@ -2087,14 +2061,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 @@ -2112,8 +2084,10 @@ 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. + +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 @@ -2206,41 +2180,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 @@ -2248,8 +2209,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 @@ -2263,17 +2224,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 @@ -2282,20 +2240,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 @@ -2304,21 +2262,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 @@ -2427,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:: @@ -2637,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 @@ -3302,8 +3257,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 diff --git a/doc/ref/statprof.texi b/doc/ref/statprof.texi index 5b99fb6b8..850c5bd2e 100644 --- a/doc/ref/statprof.texi +++ b/doc/ref/statprof.texi @@ -1,225 +1,121 @@ @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 @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 +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. -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. +@heading Implementation notes -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 @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. +@heading Usage -@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,131 @@ 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 defun +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 -@anchor{statprof with-statprof}@defspec with-statprof args -Profile the expressions in the body, and return the body's return -value. +Profiling can also be enabled and disabled manually. -Keyword arguments: +@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 +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/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}. diff --git a/doc/ref/sxml.texi b/doc/ref/sxml.texi index 75867f3a6..19125091c 100644 --- a/doc/ref/sxml.texi +++ b/doc/ref/sxml.texi @@ -1,8 +1,12 @@ @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, +@c which is in the public domain according to +@c and . + @node SXML @section SXML @@ -17,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. @@ -28,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 @@ -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 @@ -271,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 @@ -576,7 +580,7 @@ A traversal combinator in the spirit of @code{pre-post-order}. @example bindings := (...) -binding := ( ...) +binding := ( ...) | (*default* . ) | (*text* . ) tag := @@ -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 diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 6616af446..ac3889f41 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. @@ -80,11 +82,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 @@ -143,27 +146,40 @@ 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 -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 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 @@ -175,6 +191,18 @@ 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 +absolute value, we would have to walk the frames, relocating frame +pointers. + @node Variables and the VM @subsection Variables and the VM @@ -213,8 +241,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. @@ -261,54 +290,72 @@ 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 #xea4ce4: - 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 7 1) ;; anonymous procedure at #xea4d04 (1 free var) + 4 (free-set! 1 0 0) ;; free var 0 + 6 (mov 0 1) + 7 (return-values 2) ;; 1 value ---------------------------------------- -Disassembly of anonymous procedure at #x203be50: +Disassembly of anonymous procedure at #xea4d04: - 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 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 2 1 3) + 13 (return-values 2) ;; 1 value @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 @@ -397,6 +444,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 @@ -418,7 +469,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. @@ -429,10 +480,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. @@ -450,7 +507,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 @@ -476,7 +533,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 @@ -502,10 +559,15 @@ 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. +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:: @@ -518,8 +580,11 @@ instructions may be added over time. * Dynamic Environment Instructions:: * Miscellaneous Instructions:: * Inlined Scheme Instructions:: +* Inlined Atomic Instructions:: * Inlined Mathematical Instructions:: * Inlined Bytevector Instructions:: +* Unboxed Integer Arithmetic:: +* Unboxed Floating-Point Arithmetic:: @end menu @@ -530,8 +595,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 @@ -541,7 +606,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 @@ -551,12 +622,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 @@ -570,16 +641,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 @@ -595,23 +666,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{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 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 @@ -631,7 +702,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, @@ -649,23 +720,23 @@ 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}. 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 @@ -678,7 +749,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 @@ -688,31 +759,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 @@ -720,16 +791,13 @@ 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} -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{_} @@ -753,21 +821,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} @@ -777,26 +845,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}. @@ -806,7 +874,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. @@ -827,7 +895,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 @@ -849,25 +917,24 @@ 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} -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 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. @@ -879,10 +946,17 @@ 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 +@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 @@ -899,60 +973,59 @@ 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} -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. +@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} +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-= 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 @@ -967,17 +1040,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 @@ -988,7 +1061,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 @@ -1002,7 +1075,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. @@ -1014,7 +1087,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 @@ -1031,19 +1104,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. @@ -1075,7 +1148,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}. @@ -1094,7 +1167,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 @@ -1107,7 +1180,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}. @@ -1119,14 +1192,30 @@ 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 +@deftypefn Instruction {} current-thread s24:@var{dst} +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 @@ -1136,6 +1225,41 @@ 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 + +@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 @@ -1145,107 +1269,162 @@ 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} -Store the length of the vector in @var{src} in @var{dst}. +@deftypefn Instruction {} vector-length s12:@var{dst} s12:@var{src} +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 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}. +store it in @var{dst}. The @var{idx} value should be an unboxed +unsigned 64-bit integer. @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} -Store @var{src} into the vector @var{dst} at index @var{idx}. +@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}. The +@var{idx} value should be an unboxed unsigned 64-bit integer. @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}. +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 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}. +it in @var{dst}. The @var{idx} value should be an unboxed unsigned +64-bit integer. @end deftypefn -@deftypefn Instruction {} struct-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -Store @var{src} into the struct @var{dst} at slot @var{idx}. +@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}. The +@var{idx} value should be an unboxed unsigned 64-bit integer. @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} -Store the length of the string in @var{src} in @var{dst}. +@deftypefn Instruction {} string-length s12:@var{dst} s12:@var{src} +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 u8:@var{dst} u8:@var{src} u8:@var{idx} -Fetch the character at position @var{idx} in the string in @var{src}, and store -it in @var{dst}. +@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}. The @var{idx} value should be an unboxed +unsigned 64-bit integer. @end deftypefn -@deftypefn Instruction {} cons u8:@var{dst} u8:@var{car} u8:@var{cdr} +@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 -@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 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 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 @@ -1260,58 +1439,62 @@ 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} -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 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} -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 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 +@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 @@ -1322,32 +1505,188 @@ 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-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} +@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. + +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! 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. + +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 {} 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}, @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} +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 + +@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/doc/ref/web.texi b/doc/ref/web.texi index 2311b8225..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,22 +232,18 @@ 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 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 +260,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 @@ -318,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 @@ -747,9 +790,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 @@ -1417,7 +1460,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/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 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 \ diff --git a/guile-readline/readline.c b/guile-readline/readline.c index aac6e18c2..c15275dd3 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, @@ -47,12 +47,14 @@ 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 } }; 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 +62,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 +111,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 +149,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 +168,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 +177,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 +201,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 +253,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 +291,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 +315,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 +331,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 +347,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 +362,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 +373,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 +412,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 +529,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,15 +539,18 @@ 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); + 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); diff --git a/lib/Makefile.am b/lib/Makefile.am index 5d9c902fc..6336db4cf 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-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 @@ -21,9 +21,9 @@ # 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 --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 subdir-objects +AUTOMAKE_OPTIONS = 1.9.6 gnits SUBDIRS = noinst_HEADERS = @@ -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) @@ -92,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 @@ -101,9 +108,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 +185,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 +211,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 @@ -406,7 +426,9 @@ EXTRA_DIST += dosname.h ## begin gnulib module dup2 +if gl_GNULIB_ENABLED_dup2 +endif EXTRA_DIST += dup2.c EXTRA_libgnu_la_SOURCES += dup2.c @@ -493,12 +515,23 @@ 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 +## 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) @@ -645,8 +678,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 +734,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 +796,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 +839,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 +877,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 +897,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 +917,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 @@ -913,6 +976,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 @@ -1042,7 +1133,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 +1144,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 @@ -1317,11 +1412,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' \ @@ -1377,7 +1479,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' \ @@ -1394,7 +1501,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 +1512,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 +1523,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 +1534,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 @@ -1437,14 +1552,36 @@ 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 + +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 @@ -1557,7 +1694,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 +1765,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 +1839,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 +1868,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 +1984,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 +1995,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 @@ -1911,31 +2062,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 @@ -1958,7 +2084,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 +2104,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 +2192,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; \ @@ -2091,6 +2224,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' \ @@ -2112,6 +2246,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 $@ @@ -2286,6 +2421,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' \ @@ -2315,6 +2451,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' \ @@ -2337,6 +2474,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 +2496,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 +2507,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 +2928,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 +2956,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 +2971,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 +2986,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 @@ -2944,7 +3113,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' \ @@ -2966,6 +3134,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' \ @@ -2995,9 +3164,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' \ @@ -3016,77 +3187,16 @@ EXTRA_DIST += unistd.in.h ## end gnulib module unistd -## begin gnulib module unistr/base +## begin gnulib module unsetenv -BUILT_SOURCES += $(LIBUNISTRING_UNISTR_H) +if gl_GNULIB_ENABLED_unsetenv -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 +EXTRA_DIST += unsetenv.c -## end gnulib module unistr/u8-mbtouc +EXTRA_libgnu_la_SOURCES += unsetenv.c -## 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 +## end gnulib module unsetenv ## begin gnulib module useless-if-before-free @@ -3097,7 +3207,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 @@ -3143,6 +3255,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' \ @@ -3250,7 +3363,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 +3374,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 @@ -3273,6 +3389,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' \ @@ -3293,6 +3410,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 @@ -3306,10 +3424,19 @@ 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 libgnu_la_SOURCES += xsize.h xsize.c +endif ## end gnulib module xsize diff --git a/lib/accept.c b/lib/accept.c index b216c6bd6..1aee71f42 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-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/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/lib/alignof.h b/lib/alignof.h index 280f3e384..53583b833 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-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 e3aa62d2d..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-2014 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 3f5df4776..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-2014 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 7806f6888..1e8819cd9 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-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 new file mode 100644 index 000000000..cef2a7353 --- /dev/null +++ b/lib/assure.h @@ -0,0 +1,37 @@ +/* Run-time assert-like macros. + + 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 + 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..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-2014 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.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..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-2014 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 @@ -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..666e800c7 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-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 aad27f593..bfc694e15 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-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 130c79dfb..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-2014 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.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..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-2014 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 @@ -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..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-2014 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 5059cc659..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-2014 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 44d375148..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-2014 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 @@ -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..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-2014 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 a999c9c84..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-2014 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 7e810357b..d253d4856 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-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 9d2e0276a..bb635c3b0 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-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 8fe2507d9..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-2014 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 @@ -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..d3a2e124a 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-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 616ea356e..a0d2b6806 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-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 3418bd9dc..e5a31e34c 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-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 @@ -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..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-2014 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 @@ -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..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-2014 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 e31cb6190..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-2014 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 @@ -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..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-2014 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 9709b7a64..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-2014 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 @@ -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..eb7b8d365 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-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 8dbb5f97a..48c5d935d 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-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 1cd197002..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-2014 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 @@ -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..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-2014 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 5ff0f73fc..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-2014 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 085c379b1..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-2014 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 3faa5eede..48567817f 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-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 e814eaba5..2b0625359 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-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 928e151b0..7698e43ff 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-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 a00f937ed..5305fb3ae 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-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 6eff94574..8bcf890c9 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-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 17ccc8e29..4832548f1 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-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 99475ff65..8304751a4 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-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 4d67afb92..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-2014 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 954b94dce..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-2014 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 @@ -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..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-2014 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 2fab6fa02..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-2014 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 d0c589da1..20d5513d4 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-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 6581dd55a..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-2014 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 f8cfe5d78..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-2014 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 e5b3eaea3..e36e57bb0 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-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 d26bae592..08d0ead77 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-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 0b2fb2b73..eabbd246c 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-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 330d8dad4..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-2014 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 @@ -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..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-2014 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 new file mode 100644 index 000000000..845282dd3 --- /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-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 . */ + +#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..b7cd5d19e --- /dev/null +++ b/lib/hard-locale.h @@ -0,0 +1,25 @@ +/* Determine whether a locale is hard. + + 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 + 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..c0f1a8352 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-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 ed95ed719..0864267ef 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-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 6e286734d..823cf452f 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-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 fc19d44e2..48a28dbe4 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-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 43b23eb39..c074a8c25 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-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 462951968..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-2014 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 @@ -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..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-2014 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 new file mode 100644 index 000000000..eb06b6917 --- /dev/null +++ b/lib/intprops.h @@ -0,0 +1,458 @@ +/* intprops.h -- properties of integer types + + 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 + 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 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 << (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. */ +#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) << (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. + 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 +/* 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__ \ + || (1210 <= __IBMC__ && 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 (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, + 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 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_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) \ + : (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_P +# 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) + +/* 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 _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) \ + (_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..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-2014 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 217de79df..8dd72a305 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-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 1557733bf..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-2014 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 b0498ef08..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-2014 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 11efbf8d8..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-2014 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 9e2aa2f54..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-2014 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 c7a66ca3a..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-2014 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 9cf090caa..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-2014 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 dbf9d5dd1..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-2014 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 136742eab..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-2014 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 f4a281a33..689e82c9a 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-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 @@ -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/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 9db1f8cef..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-2014 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 912f1b7a7..284415a08 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-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 7f09567ce..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-2014 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 @@ -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 && 2 + strlen (pdot + 1) + 1 <= sizeof (buf)) + 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..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-2014 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 a10b129ca..50ccae610 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-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 ed2767be0..c38035f0d 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-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 ef8d332f8..2ec8cb9d5 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-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 d1132d3e4..d266290ac 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-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 cff1188f3..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-2014 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 c6e292a74..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-2014 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 3e95f2333..c0ff33568 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-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 5810afa54..3b61ca2b9 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-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.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..53d385e54 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-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) @@ -2205,7 +2320,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) \ @@ -2258,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 dff12962d..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-2014 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 @@ -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..4d0b1184a 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-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 df11ad2bf..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-2014 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 bd9d3aa6b..fbed5dc2f 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-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 c1caad3a2..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-2014 +/* 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 f1b802b57..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-2014 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/mkstemp.c b/lib/mkostemp.c similarity index 75% rename from lib/mkstemp.c rename to lib/mkostemp.c index 0af69f9c3..d2190bd6e 100644 --- a/lib/mkstemp.c +++ b/lib/mkostemp.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2014 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. @@ -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/lib/mktime-internal.h b/lib/mktime-internal.h new file mode 100644 index 000000000..bfde06fa2 --- /dev/null +++ b/lib/mktime-internal.h @@ -0,0 +1,37 @@ +/* mktime variant that also uses an offset guess + + 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.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..2efd44a22 --- /dev/null +++ b/lib/mktime.c @@ -0,0 +1,630 @@ +/* Convert a 'struct tm' to a time_t value. + Copyright (C) 1993-2017 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 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 + 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..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-2014 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 c6df57e93..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-2014 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 9b1eb598e..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-2014 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 1917325b3..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-2014 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 3613fb5a5..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-2014 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 8ab66a1df..51dc48bfd 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-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 83d2c77af..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-2014 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 @@ -20,13 +20,71 @@ /* 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]; + 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,47 +94,18 @@ 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: - 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. */ @@ -95,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; @@ -111,160 +140,181 @@ 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__ - return "UTF-8"; +# ifdef __BEOS__ + 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: 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: 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: - return "AM"; + if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) + return (char *) "AM"; + return nlbuf; case PM_STR: - return "PM"; + tmm.tm_hour = 12; + if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) + return (char *) "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 ""; + return (char *) ""; 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. */ + return (char *) "\0\0\0\0\0\0\0\0\0\0"; + /* 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: - 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 293c65169..78e13e3bf 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-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 dbc315707..4f60219d2 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-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 f6fd06e4c..4dd5e2be7 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-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 15ed6c28e..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-2014 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 03aed5ef9..349a85950 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-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 4e4e894e7..13e3dcf28 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-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 7b1e58266..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-2014 Free Software Foundation, Inc. + Copyright 2001-2003, 2006-2017 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..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-2014 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 9673e6ddc..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-2014 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 831c14738..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-2014 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 e6a09a8de..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-2014 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 44d6f5513..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-2014 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 de8caa712..ba1cc07dd 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-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 2f04eea9b..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-2014 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 4efe8ce23..5385cfd5a 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-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 ef502f57b..d624fec89 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-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 fc7e12406..d5b115d3f 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-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 0d4fba076..bf4b87310 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-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 9adfb0df0..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-2014 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 45449cbba..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-2014 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 56faf11c4..9fd4fed99 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-2017 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..d1de1395c 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-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 54327c69e..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-2014 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. @@ -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 *); @@ -650,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 0343ee6e3..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-2014 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 . @@ -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..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-2014 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,14 +33,16 @@ #include #include +#include "intprops.h" + #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 +64,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 +89,6 @@ # ifndef _RE_DEFINE_LOCALE_FUNCTIONS # define _RE_DEFINE_LOCALE_FUNCTIONS 1 # include -# include # include # endif #endif @@ -114,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 @@ -137,7 +134,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 +149,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 +438,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 +547,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 +851,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 +872,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..ef52b243a 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-2017 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,18 +346,20 @@ 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; 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. */ @@ -409,8 +395,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 +485,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 +564,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 +593,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 +611,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 +623,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 +832,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 +856,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 +867,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 +945,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 +993,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 +1074,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 +1090,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 +1102,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 +1157,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 +1171,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 +1254,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 +1272,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 +1294,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 +1319,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 +1334,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 +1350,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 +1391,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 +1484,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 +1870,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 +1953,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 +2069,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 +2085,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 +2094,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 +2147,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 +2551,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 +2617,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 +2701,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 +2806,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 +2885,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 +3161,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 +3247,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 +3372,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 +3434,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 +3745,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 +3757,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 +3880,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 +3936,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 +4176,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 +4297,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 +4317,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..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-2014 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 @@ -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..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-2014 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 d1c2aac5a..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-2014 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 6c9639f40..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-2014 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 6cd5f68fc..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-2014 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 3e7ffd627..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-2014 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 45a61463a..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-2014 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 f85a3cce8..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-2014 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 7b86173bb..b8c64c7a8 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-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 @@ -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..fe50a9569 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-2017 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..d4a17a5a8 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-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 69b8ebc9f..1941beca1 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-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 50e686025..be43c0cec 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-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 2b905daa0..8d4c1f070 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-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 54b7728dd..16496dcbf 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-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 057fa9ef5..2a272cccc 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-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,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..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-2014 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 3240e4ec0..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-2014 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 3f847257c..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-2014 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 680ca0fff..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-2014 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 0b8cbf88f..51ef37443 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-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 c10d4f6ad..1c3500ad8 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-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 98fe879ee..8aa275636 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-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 @@ -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..9698f32c6 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-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 @@ -20,20 +20,20 @@ #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 +#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 570001361..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-2014 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 @@ -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; @@ -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 60bbd693e..cf261789b 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-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 29861efe1..2c00533d6 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-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 @@ -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..301df94a3 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-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 204c4bcf0..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-2014 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 @@ -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..11e8e13f4 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-2017 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 @@ -80,54 +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) ? (- ((zero) + 1) << ((bits) ? (bits) - 1 : 0)) : (zero)) +# define _STDINT_MIN(signed, bits, 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) +# define _STDINT_MAX(signed, bits, zero) \ + (((((zero) + 1) << ((bits) ? (bits) - 1 - (signed) : 0)) - 1) * 2 + 1) #if !GNULIB_defined_stdint_types @@ -136,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 @@ -163,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 */ @@ -219,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 */ @@ -251,50 +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 */ -#undef intptr_t -#undef uintptr_t +/* 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 +# define intptr_t gl_intptr_t +# define uintptr_t gl_uintptr_t +# endif /* 7.18.1.5. Greatest-width integer types */ @@ -305,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 @@ -339,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 */ @@ -349,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 */ @@ -387,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 */ @@ -426,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. @@ -544,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 */ @@ -577,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 faa778b1d..3306464b9 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-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 @@ -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, @@ -113,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. */ @@ -718,11 +743,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..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-2014 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 @@ -520,6 +520,44 @@ _GL_CXXALIAS_SYS (putenv, int, (char *string)); _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 +# 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 +# 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 + #if @GNULIB_RANDOM_R@ # if !@HAVE_RANDOM_R@ diff --git a/lib/strdup.c b/lib/strdup.c index bde582927..ece20c5bf 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-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 0f7bc72b2..831ded2e2 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-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 eb458d117..8091f3d08 100644 --- a/lib/strftime.c +++ b/lib/strftime.c @@ -1,22 +1,22 @@ -/* Copyright (C) 1991-2001, 2003-2007, 2009-2014 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 @@ -30,6 +30,7 @@ # else # include "strftime.h" # endif +# include "time-internal.h" #endif #include @@ -62,10 +63,10 @@ extern char *tzname[]; #endif #include -#include #include #include #include +#include #ifdef COMPILE_WIDE # 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 @@ -257,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) @@ -314,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); @@ -338,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) { @@ -369,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 @@ -385,12 +381,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 +389,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,21 +403,45 @@ 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 +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; @@ -440,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))) @@ -454,6 +474,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 +506,35 @@ 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 + } + /* The tzset() call might have changed the value. */ + if (!(zone && *zone) && tp->tm_isdst >= 0) + { /* POSIX.1 requires that local time zone information be used as though strftime called tzset. */ # if HAVE_TZSET - tzset (); + if (!*tzset_called) + { + tzset (); + *tzset_called = true; + } # endif + zone = tzname_vec[tp->tm_isdst != 0]; } #endif + if (! zone) + zone = ""; if (hour12 > 12) hour12 -= 12; @@ -643,7 +681,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 +719,43 @@ 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 +#define DO_TZ_OFFSET(d, mask, v) \ + do \ + { \ + digits = d; \ + 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) @@ -783,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; @@ -827,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 @@ -1097,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; @@ -1124,7 +1184,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 +1325,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 +1359,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 +1398,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 { @@ -1354,8 +1406,18 @@ 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 (<m); + lt = mktime_z (tz, <m); if (lt == (time_t) -1) { @@ -1364,7 +1426,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,13 +1436,14 @@ 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); } #endif + negative_number = diff < 0 || (diff == 0 && *zone == '-'); hour_diff = diff / 60 / 60; min_diff = diff / 60 % 60; sec_diff = diff % 60; @@ -1388,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 */ @@ -1402,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; @@ -1434,34 +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 - - -#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..523898856 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-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 @@ -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..5aec9bb83 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-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 a4e425aa2..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-2014 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 eaaaa9dda..c0d517820 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-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 @@ -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 @@ -400,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 @@ -428,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 @@ -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..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-2014 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 1df6946a5..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-2014 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 7e5c3a389..cba4b412b 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-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,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..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-2014 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 32c23a055..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-2014 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 f19326e02..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-2014 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 b3babfb80..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-2014 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 c8d0bb48f..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-2014 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 @@ -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..ec57b7c22 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-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 f0f7e7f29..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-2014 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 @@ -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..5b740e852 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-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,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..375e1341a --- /dev/null +++ b/lib/time-internal.h @@ -0,0 +1,49 @@ +/* Time internal interface + + 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 + 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) 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..296ea51f5 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-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 @@ -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 @@ -213,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@ @@ -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..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-2014 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 new file mode 100644 index 000000000..c6e6083a6 --- /dev/null +++ b/lib/time_rz.c @@ -0,0 +1,322 @@ +/* Time zone functions such as tzalloc and localtime_rz + + 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 + 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 "flexmember.h" +#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 (FLEXSIZEOF (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..168da8ead --- /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-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 + 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..f403e3de7 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-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 @@ -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..f110f46ca 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-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.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..2f862c853 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-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__ @@ -401,6 +405,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 @@ -770,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)); @@ -1287,13 +1297,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 +1428,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 deleted file mode 100644 index 73d2c23c0..000000000 --- a/lib/unistr.in.h +++ /dev/null @@ -1,750 +0,0 @@ -/* Elementary Unicode string functions. - 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 - 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 02cdacd9d..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-2014 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 bfa96f4ab..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-2014 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 9c2095b68..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-2014 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 2b389deb7..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-2014 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 3a75a4118..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-2014 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 b2c2b9b41..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-2014 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 8d94bf57a..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-2014 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 1ce271fe8..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-2014 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 e5ff9923c..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-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 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/lib/unsetenv.c b/lib/unsetenv.c new file mode 100644 index 000000000..708119346 --- /dev/null +++ b/lib/unsetenv.c @@ -0,0 +1,127 @@ +/* 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 + 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..412219bf4 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-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 @@ -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); } } @@ -4844,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 @@ -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..3631ff8c8 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-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 78d543f04..2d996ad3a 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-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 @@ -263,7 +268,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..2014ce9c4 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-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 3946d4945..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-2014 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 1874b4d7e..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-2014 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 @@ -30,15 +30,23 @@ #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 __MINGW32__ && defined __STRING_H_SOURCED__) \ + || 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 -> -> -> 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. */ @@ -105,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; @@ -440,6 +448,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..ee5906c30 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-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 b5b6093d7..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-2014 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 51cc1d91e..c451a5011 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-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 83cb960b5..d78767188 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-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/libguile.h b/libguile.h index 4904d6980..3f7f0b791 100644 --- a/libguile.h +++ b/libguile.h @@ -30,11 +30,11 @@ 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" #include "libguile/async.h" +#include "libguile/atomic.h" #include "libguile/boolean.h" #include "libguile/bitvectors.h" #include "libguile/bytevectors.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" @@ -87,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/.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 8302a1805..2214a4aa3 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. ## @@ -120,11 +120,11 @@ 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 \ async.c \ + atomic.c \ backtrace.c \ boolean.c \ bitvectors.c \ @@ -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 \ @@ -191,7 +192,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ random.c \ rdelim.c \ read.c \ - root.c \ rw.c \ scmsigs.c \ script.c \ @@ -212,6 +212,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ strports.c \ struct.c \ symbols.c \ + syntax.c \ threads.c \ throw.c \ trees.c \ @@ -229,11 +230,11 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ DOT_X_FILES = \ alist.x \ - arbiters.x \ array-handle.x \ array-map.x \ arrays.x \ async.x \ + atomic.x \ backtrace.x \ boolean.x \ bitvectors.x \ @@ -252,6 +253,7 @@ DOT_X_FILES = \ evalext.x \ expand.x \ extensions.x \ + fdes-finalizers.x \ feature.x \ filesys.x \ fluids.x \ @@ -295,7 +297,6 @@ DOT_X_FILES = \ random.x \ rdelim.x \ read.x \ - root.x \ rw.x \ scmsigs.x \ script.x \ @@ -316,6 +317,7 @@ DOT_X_FILES = \ strports.x \ struct.x \ symbols.x \ + syntax.x \ threads.x \ throw.x \ trees.x \ @@ -335,11 +337,11 @@ EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = \ alist.doc \ - arbiters.doc \ array-handle.doc \ array-map.doc \ arrays.doc \ async.doc \ + atomic.doc \ backtrace.doc \ boolean.doc \ bitvectors.doc \ @@ -358,6 +360,7 @@ DOT_DOC_FILES = \ evalext.doc \ expand.doc \ extensions.doc \ + fdes-finalizers.doc \ feature.doc \ filesys.doc \ fluids.doc \ @@ -397,7 +400,6 @@ DOT_DOC_FILES = \ random.doc \ rdelim.doc \ read.doc \ - root.doc \ rw.doc \ scmsigs.doc \ script.doc \ @@ -418,6 +420,7 @@ DOT_DOC_FILES = \ strports.doc \ struct.doc \ symbols.doc \ + syntax.doc \ threads.doc \ throw.doc \ trees.doc \ @@ -443,9 +446,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 \ - $(DOT_I_FILES) 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. @@ -455,8 +458,8 @@ 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 \ - win32-uname.c \ + debug-malloc.c \ + posix-w32.c \ locale-categories.h ## delete guile-snarf.awk from the installation bindir, in case it's @@ -504,8 +507,13 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ elf.h \ srfi-14.i.c \ quicksort.i.c \ - win32-uname.h \ - private-options.h ports-internal.h + atomics-internal.h \ + cache-internal.h \ + posix-w32.h \ + private-options.h \ + ports-internal.h \ + syntax.h \ + weak-list.h # vm instructions noinst_HEADERS += vm-engine.c @@ -560,11 +568,11 @@ modincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION)/libguile modinclude_HEADERS = \ __scm.h \ alist.h \ - arbiters.h \ array-handle.h \ array-map.h \ arrays.h \ async.h \ + atomic.h \ backtrace.h \ bdw-gc.h \ boolean.h \ @@ -586,6 +594,7 @@ modinclude_HEADERS = \ evalext.h \ expand.h \ extensions.h \ + fdes-finalizers.h \ feature.h \ finalizers.h \ filesys.h \ @@ -639,7 +648,6 @@ modinclude_HEADERS = \ rdelim.h \ read.h \ regex-posix.h \ - root.h \ rw.h \ scmsigs.h \ script.h \ @@ -694,7 +702,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 @@ -738,7 +746,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 @@ -752,9 +761,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 @@ -762,7 +771,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) @@ -815,13 +824,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" ; \ diff --git a/libguile/__scm.h b/libguile/__scm.h index 31e395285..62ceeeb9c 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. @@ -421,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 @@ -474,11 +469,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 97ddaf2ab..093815d98 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__) @@ -268,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 6 +#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/alist.c b/libguile/alist.c index 82c70a03c..b29186020 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); @@ -269,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 @@ -287,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 @@ -305,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/arbiters.c b/libguile/arbiters.c deleted file mode 100644 index 831e0a230..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_unlocked ("#', 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/array-handle.c b/libguile/array-handle.c index 2252ecc9a..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,31 +170,32 @@ 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: { - 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) { @@ -227,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: @@ -324,15 +327,17 @@ 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 ((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 938f0a7b9..79383969d 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 @@ -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" @@ -42,23 +41,11 @@ #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"; -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) { @@ -99,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) { @@ -167,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); @@ -224,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); @@ -255,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); @@ -276,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]; } @@ -307,308 +296,75 @@ 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) { + 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 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 { + scm_t_array_handle *hs; + size_t restn = scm_ilength (ras); 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)); + 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); } + scm_array_handle_release (&h2); } scm_array_handle_release (&h1); } @@ -645,30 +401,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; @@ -706,15 +476,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++) { @@ -732,6 +499,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]) @@ -862,7 +630,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); @@ -873,6 +642,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_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" + "@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-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-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_slice_for_each +{ + 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] #include #include -#include #include "verify.h" @@ -39,7 +38,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" @@ -58,10 +56,25 @@ #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) +{ + 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, @@ -71,10 +84,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 @@ -84,13 +97,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 @@ -100,18 +112,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 @@ -136,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; @@ -270,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.") @@ -314,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) { @@ -454,6 +433,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_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-cell-ref}, @code{array-cell-set!}.\n\n" + "@code{array-slice} may return a rank-0 array. For example:\n" + "@lisp\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_slice +{ + 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_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-slice}, @code{array-cell-set!}.\n\n" + "@code{array-cell-ref} never returns a rank 0 array. For example:\n" + "@lisp\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_cell_ref +{ + 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_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-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-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-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-cell-set! B 15) @result{} #0(15)\n" + "@end lisp") +#define FUNC_NAME s_scm_array_cell_set_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), @@ -566,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); @@ -607,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 @@ -735,15 +895,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 +920,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 +941,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 +974,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/arrays.h b/libguile/arrays.h index 5f4059792..b56abef94 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -37,24 +37,36 @@ /** 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, 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_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); +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) +/* 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)) @@ -69,6 +81,7 @@ SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); 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/async.c b/libguile/async.c index 1e5bc302d..fc03078e7 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -24,9 +24,9 @@ #endif #include "libguile/_scm.h" +#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" @@ -44,222 +44,189 @@ /* {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 an scm_async_tick (), it will call all procedures on this + * list in the order they were added to the 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 +void +scm_i_async_push (scm_i_thread *t, SCM proc) { - SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk)); -} -#undef FUNC_NAME + SCM asyncs; -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 + /* The usual algorithm you'd use for atomics with GC would be + something like: -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)) + 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 { - 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); + /* 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; } - return SCM_BOOL_T; + while (!scm_atomic_compare_and_swap_scm (&t->pending_asyncs, &asyncs, + scm_cons (proc, asyncs))); } -#undef FUNC_NAME - +/* Precondition: there are pending asyncs. */ +SCM +scm_i_async_pop (scm_i_thread *t) +{ + while (1) + { + SCM asyncs, last_pair, penultimate_pair; -static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; + last_pair = asyncs = scm_atomic_ref_scm (&t->pending_asyncs); + penultimate_pair = SCM_BOOL_F; -/* System asyncs. */ + /* 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; - /* 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 = t->active_asyncs; - t->active_asyncs = SCM_EOL; - } - else - asyncs = SCM_EOL; - scm_i_pthread_mutex_unlock (&async_mutex); + while (!scm_is_null (scm_atomic_ref_scm (&t->pending_asyncs))) + scm_call_0 (scm_i_async_pop (t)); +} - while (scm_is_pair (asyncs)) - { - SCM next = SCM_CDR (asyncs); - SCM_SETCDR (asyncs, SCM_BOOL_F); - scm_call_0 (SCM_CAR (asyncs)); - asyncs = next; - } +struct scm_thread_wake_data { + 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_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 + 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_queue_async_cell (SCM c, scm_i_thread *t) +scm_i_wait_finished (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); + scm_atomic_set_pointer ((void **)&t->wake, NULL); } int -scm_i_setup_sleep (scm_i_thread *t, - SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex, - int sleep_fd) +scm_i_prepare_to_wait_on_fd (scm_i_thread *t, int fd) { - int pending; + 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); +} - 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; +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_i_reset_sleep (scm_i_thread *t) +scm_c_wait_finished (void) { - 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_i_wait_finished (SCM_I_CURRENT_THREAD); } SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, @@ -274,24 +241,53 @@ 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; + struct scm_thread_wake_data *wake; if (SCM_UNBNDP (thread)) t = SCM_I_CURRENT_THREAD; 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); } - scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t); + + 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. */ + 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 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->kind == WAIT_COND) + { + 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); + } + else if (wake->kind == WAIT_FD) + { + 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->data.wait_fd.fd, &dummy, 1); + } + else + abort (); + } + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -425,31 +421,11 @@ scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) return ans; } - -/* 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. */ - -void -scm_critical_section_start (void) -{ - SCM_CRITICAL_SECTION_START; -} - -void -scm_critical_section_end (void) -{ - SCM_CRITICAL_SECTION_END; -} - 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..2bca16df9 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -25,23 +25,20 @@ #include "libguile/__scm.h" -#include "libguile/root.h" #include "libguile/threads.h" 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 *); -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 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); @@ -50,57 +47,16 @@ 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_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 *); -/* 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) - -# 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 () -# define SCM_CRITICAL_SECTION_END scm_critical_section_end () - -#endif /* !BUILDING_LIBGUILE */ +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); 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 new file mode 100644 index 000000000..3c4f0cbbd --- /dev/null +++ b/libguile/atomics-internal.h @@ -0,0 +1,185 @@ +#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 + + + + +#ifdef HAVE_STDATOMIC_H + +#include + +static inline uint32_t +scm_atomic_subtract_uint32 (uint32_t *loc, uint32_t 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) +{ + 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_uintptr_t *a_loc = (atomic_uintptr_t *) loc; + atomic_store (a_loc, (uintptr_t) val); +} +static inline void * +scm_atomic_ref_pointer (void **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_uintptr_t *a_loc = (atomic_uintptr_t *) loc; + atomic_store (a_loc, SCM_UNPACK (val)); +} +static inline SCM +scm_atomic_ref_scm (SCM *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) +{ + 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) +{ + 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 */ + +/* 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 *loc, uint32_t arg) +{ + uint32_t ret; + scm_i_pthread_mutex_lock (&atomics_lock); + ret = *loc; + *loc -= arg; + scm_i_pthread_mutex_unlock (&atomics_lock); + return ret; +} +static inline int +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 (*loc == *expected) + { + *loc = desired; + ret = 1; + } + else + { + *expected = *loc; + ret = 0; + } + scm_i_pthread_mutex_unlock (&atomics_lock); + 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) +{ + 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); + return ret; +} + +#endif /* HAVE_STDATOMIC_H */ + +#endif /* SCM_ATOMICS_INTERNAL_H */ diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 0c0f11007..495a68bad 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -58,15 +58,19 @@ 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; } #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; } @@ -524,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; @@ -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, @@ -585,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/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); diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index d594317b2..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) { @@ -57,12 +70,12 @@ 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; 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; @@ -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 41d5b6c85..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,26 +182,18 @@ #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_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)) +#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; @@ -228,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); } @@ -258,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); } @@ -395,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); @@ -417,17 +414,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; } @@ -435,8 +432,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; @@ -556,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))) @@ -587,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); @@ -712,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), @@ -817,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 */, @@ -850,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); @@ -875,10 +870,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; @@ -899,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); \ \ @@ -918,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) \ @@ -1067,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)); } @@ -1079,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)); } @@ -1091,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); @@ -1106,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); @@ -1334,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, \ @@ -1342,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, \ @@ -1352,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, \ @@ -1669,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)) \ @@ -1694,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)); @@ -1702,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); \ @@ -1722,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); \ \ @@ -1885,9 +1888,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"))); } @@ -1905,7 +1908,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); \ \ @@ -2022,7 +2025,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); \ \ @@ -2099,10 +2102,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, @@ -2119,7 +2126,4 @@ 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/bytevectors.h b/libguile/bytevectors.h index a5eeaea0c..77f0006a4 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -124,10 +124,23 @@ 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) +#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" diff --git a/libguile/cache-internal.h b/libguile/cache-internal.h new file mode 100644 index 000000000..4c1732f81 --- /dev/null +++ b/libguile/cache-internal.h @@ -0,0 +1,112 @@ +#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 16 + +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[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; + 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/continuations.c b/libguile/continuations.c index 8dca62e2d..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 @@ -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" @@ -92,11 +91,11 @@ 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_unlocked ('>', port); + scm_putc ('>', port); return 1; } @@ -122,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; @@ -139,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); @@ -162,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; } @@ -182,8 +184,8 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame) struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont); 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 = data->fp_offset; + frame->sp_offset = data->stack_size; frame->ip = data->ra; return 1; @@ -298,12 +300,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); @@ -401,7 +397,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/control.c b/libguile/control.c index 347d69715..636718d02 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].as_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,22 @@ 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, + 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); return make_partial_continuation (vm_cont); @@ -130,7 +131,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 +143,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 +163,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].as_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].as_scm = argv[i]; /* Jump! */ SCM_I_LONGJMP (*registers, 1); @@ -208,10 +207,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/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/conv-integer.i.c b/libguile/conv-integer.i.c index 4cf887cb6..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; } @@ -117,7 +122,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; diff --git a/libguile/cpp-E.syms b/libguile/cpp-E.syms index 3fbcbfe3a..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,18 +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 @@ -63,6 +73,7 @@ EMSGSIZE EMULTIHOP ENAMETOOLONG ENAVAIL +ENEEDAUTH ENETDOWN ENETRESET ENETUNREACH @@ -104,6 +115,10 @@ EOWNERDEAD EPERM EPFNOSUPPORT EPIPE +EPROCLIM +EPROCUNAVAIL +EPROGMISMATCH +EPROGUNAVAIL EPROTO EPROTONOSUPPORT EPROTOTYPE @@ -112,7 +127,9 @@ EREMCHG EREMOTE EREMOTEIO ERESTART +ERFKILL EROFS +ERPCMISMATCH ESHUTDOWN ESOCKTNOSUPPORT ESPIPE diff --git a/libguile/cpp-SIG.syms b/libguile/cpp-SIG.syms index bc5737679..728a29457 100644 --- a/libguile/cpp-SIG.syms +++ b/libguile/cpp-SIG.syms @@ -5,17 +5,16 @@ SIGBUS SIGCHLD SIGCLD SIGCONT -SIGEV_NONE -SIGEV_SIGNAL -SIGEV_THREAD -SIGEV_THREAD_ID +SIGEMT SIGFPE SIGHUP SIGILL +SIGINFO SIGINT SIGIO SIGIOT SIGKILL +SIGLOST SIGPIPE SIGPOLL SIGPROF diff --git a/libguile/debug.c b/libguile/debug.c index 878777d56..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" @@ -109,13 +108,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 diff --git a/libguile/deprecated.c b/libguile/deprecated.c index b8c3c8ce1..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" @@ -202,7 +205,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; } @@ -486,11 +488,481 @@ 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 + + + + +/* 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 + + +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 (); +} + + + + +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); +} + +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) +{ + 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); +} + + + +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 + + + +/* {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_current_dynamic_state ()); + + 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); +} + + + + +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; +} + + + + +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 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 1f13bde83..2c49076a1 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -115,8 +115,7 @@ 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_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 +202,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); @@ -219,6 +217,63 @@ 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); + + + +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); + + + +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 () + + + +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); + + + +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); + + + +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, + 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); + + + +SCM_DEPRECATED int SCM_FDES_RANDOM_P (int fdes); + + + void scm_i_init_deprecated (void); #endif 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 79198e64c..b9497b1b3 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; @@ -229,11 +223,11 @@ scm_t_bits scm_tc16_dynamic_obj; static int dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#', port); + scm_puts (" (unlinked)", port); + scm_putc ('>', port); return 1; } @@ -259,6 +253,7 @@ SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0, char *file; scm_dynwind_begin (0); + scm_i_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_i_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_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/dynstack.c b/libguile/dynstack.c index 9235ec495..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])) @@ -53,6 +55,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])) + @@ -110,6 +115,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; @@ -163,7 +169,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; @@ -230,6 +236,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) { @@ -267,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) { @@ -305,6 +345,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 +408,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 (); @@ -472,9 +525,59 @@ 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) + scm_t_ptrdiff base_fp_offset, + scm_i_jmp_buf *registers) { scm_t_bits tag = SCM_DYNSTACK_TAG (item); @@ -484,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); } @@ -525,7 +628,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; @@ -541,6 +645,25 @@ scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, SCM dynamic_state) 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 7b31acedf..bd34d25a8 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 @@ -129,8 +130,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 *); @@ -148,9 +148,11 @@ 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_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, @@ -187,8 +189,10 @@ 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 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 *, @@ -197,6 +201,12 @@ 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_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/eq.c b/libguile/eq.c index 5a6f574d2..4680de7d8 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -28,12 +28,12 @@ #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" #include "libguile/hashtab.h" #include "libguile/bytevectors.h" +#include "libguile/syntax.h" #include "libguile/struct.h" #include "libguile/goops.h" @@ -363,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/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/eval.c b/libguile/eval.c index 735e6c0b3..e9ff02a8b 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" @@ -196,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) { @@ -424,33 +429,34 @@ 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; + const void *prev_cookie; + 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); + 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; - 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; } @@ -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)); } @@ -884,7 +902,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; @@ -921,16 +940,16 @@ static int 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/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/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/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/arbiters.h b/libguile/fdes-finalizers.h similarity index 66% rename from libguile/arbiters.h rename to libguile/fdes-finalizers.h index 214e92a34..cadbb0404 100644 --- a/libguile/arbiters.h +++ b/libguile/fdes-finalizers.h @@ -1,9 +1,7 @@ -/* classes: h_files */ +#ifndef SCM_FDES_FINALIZERS_H +#define SCM_FDES_FINALIZERS_H -#ifndef SCM_ARBITERS_H -#define SCM_ARBITERS_H - -/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc. +/* 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 @@ -27,15 +25,10 @@ -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); +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); -#endif /* SCM_ARBITERS_H */ +SCM_INTERNAL void scm_register_fdes_finalizers (void); -/* - Local Variables: - c-file-style: "gnu" - End: -*/ +#endif /* SCM_FDES_FINALIZERS_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/filesys.c b/libguile/filesys.c index 95d1a9dff..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 @@ -26,15 +26,13 @@ /* 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 #endif #include +#include #include #include @@ -42,11 +40,15 @@ #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" +#include "libguile/iselect.h" #include "libguile/vectors.h" #include "libguile/dynwind.h" +#include "libguile/ports.h" +#include "libguile/ports-internal.h" #include "libguile/validate.h" #include "libguile/filesys.h" @@ -78,8 +80,6 @@ #include #endif -#include - #ifdef HAVE_STRING_H #include #endif @@ -287,6 +287,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. */ @@ -309,6 +310,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; @@ -644,24 +646,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 buffered input. */ - scm_t_port *pt = SCM_PTAB_ENTRY (element); - - if (pt->read_pos < pt->read_end) + /* Check whether port has input buffered. */ + 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. */ - 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) + /* 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, &cur) > 1) use_buf = 1; } fd = use_buf ? -1 : SCM_FPORT_FDES (element); @@ -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)); @@ -979,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 @@ -994,8 +995,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 { @@ -1257,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 @@ -1441,8 +1437,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" @@ -1461,18 +1458,52 @@ 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_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); 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); + /* 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); + } - SCM_SYSCALL (rv = mkstemp (c_tmpl)); + SCM_SYSCALL (rv = mkostemp (c_tmpl, open_flags)); if (rv == -1) SCM_SYSERROR; @@ -1481,10 +1512,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, 0); + 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 */ @@ -1515,31 +1558,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 @@ -1551,42 +1585,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 @@ -1616,22 +1636,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 @@ -1693,12 +1731,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" @@ -1706,70 +1738,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 @@ -1819,12 +1807,12 @@ SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0, static int scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts_unlocked ("#<", port); + scm_puts ("#<", port); if (!SCM_DIR_OPEN_P (exp)) - scm_puts_unlocked ("closed: ", port); - scm_puts_unlocked ("directory stream ", port); + scm_puts ("closed: ", port); + scm_puts ("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/finalizers.c b/libguile/finalizers.c index 82f292cd2..c5d69e8e3 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); } @@ -302,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); } @@ -418,10 +399,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/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/fluids.c b/libguile/fluids.c index 4e0684af8..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 @@ -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,138 +37,194 @@ #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. */ + +#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) +{ + 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); +} + +/* 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) +{ + 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) + 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); + else + scm_weak_table_putq_x (state->values, key, value); + } + } + state->has_aliased_values = 1; + 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) +{ + 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_unlocked ("#', port); + if (SCM_I_FLUID_THREAD_LOCAL_P (exp)) + scm_puts ("#', port); } void scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts_unlocked ("#', port); + scm_putc ('>', port); } + -/* Return a new fluid. */ + +#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) { - 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 | 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, @@ -181,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 @@ -190,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 @@ -200,52 +273,161 @@ 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 + +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) { - 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 (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, + 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; + { + 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); + + /* Cache this lookup. */ + fluid_set_x (dynamic_state, fluid, val); + } + + return val; } 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 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 + +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); + + /* 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) + { + 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, + 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 @@ -254,19 +436,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 +449,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 +464,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 +476,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 +553,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 +569,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,13 +611,21 @@ 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 +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) { @@ -482,7 +636,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 a550d9a34..7997ad4d3 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" @@ -36,30 +35,37 @@ 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 thread_local_values; + SCM values; + uint8_t has_aliased_values; + struct scm_cache cache; +}; #endif 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); 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); @@ -70,12 +76,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); @@ -84,6 +84,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/foreign.c b/libguile/foreign.c index 0cab6b8b0..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; @@ -313,9 +314,9 @@ 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); + scm_putc ('>', port); } @@ -370,7 +371,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 +416,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 (); @@ -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,62 +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) - -#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 * 2]; -} + code = scm_gc_malloc_pointerless (code_len * sizeof (scm_t_uint32), + "foreign code"); -/* 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 (nargs >= (1 << 24) + 1) + scm_misc_error ("make-foreign-function", "too many arguments: ~a", + scm_list_1 (scm_from_uint (nargs))); - if (code < foreign_stub_code) - return 0; - if (code > (foreign_stub_code - + (sizeof(foreign_stub_code) / sizeof(scm_t_uint32)))) - return 0; + 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); - *req = (code - foreign_stub_code) / 2; - *opt = 0; - *rest = 0; - - return 1; + 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; @@ -822,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); @@ -977,7 +991,8 @@ 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 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. */ @@ -990,8 +1005,8 @@ scm_i_foreign_call (SCM foreign, const SCM *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); @@ -1016,7 +1031,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].as_scm, 0); } /* Prepare space for the return value. On some platforms, such as @@ -1027,7 +1042,9 @@ scm_i_foreign_call (SCM foreign, const SCM *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 fbb97640b..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 @@ -93,13 +93,17 @@ 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_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, const SCM *argv); -SCM_INTERNAL int scm_i_foreign_arity (SCM foreign, - int *req, int *opt, int *rest); +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/fports.c b/libguile/fports.c index 8395f0e65..94092b872 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" @@ -72,169 +73,9 @@ #error Oops, unknown OFF_T size #endif -scm_t_bits scm_tc16_fport; +scm_t_port_type *scm_file_port_type; -/* 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 - -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. */ @@ -243,16 +84,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); @@ -281,8 +115,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) @@ -319,45 +153,20 @@ 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_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); md = scm_i_string_chars (mode); + *is_binary = 0; switch (*md) { @@ -382,7 +191,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 @@ -396,6 +205,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++) @@ -419,7 +267,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) { @@ -546,45 +395,44 @@ 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_tc16_fport, mode_bits, (scm_t_bits)fp); + port = scm_c_make_port (scm_file_port_type, 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; @@ -594,7 +442,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. */ @@ -712,7 +561,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)) { @@ -721,8 +570,8 @@ 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_putc_unlocked (' ', port); + scm_puts (SCM_PORT_TYPE (exp)->name, port); + scm_putc (' ', port); fdes = (SCM_FSTREAM (exp))->fdes; #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX) @@ -734,85 +583,72 @@ 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_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port); + scm_puts (SCM_PORT_TYPE (exp)->name, port); + scm_putc (' ', port); + scm_uintprint ((scm_t_bits) SCM_PORT (exp), 16, port); } - scm_putc_unlocked ('>', port); + scm_putc ('>', port); 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 size_t +fport_read (SCM port, SCM dst, size_t start, size_t count) { - long count; - scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_fport *fp = SCM_FSTREAM (port); + signed char *ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start; + ssize_t ret; - SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size)); - if (count == -1) - scm_syserror ("fport_fill_input"); - if (count == 0) - return (scm_t_wchar) EOF; - else + retry: + ret = read (fp->fdes, ptr, count); + if (ret < 0) { - pt->read_pos = pt->read_buf; - pt->read_end = pt->read_buf + count; - return *pt->read_buf; + if (errno == EINTR) + { + scm_async_tick (); + goto retry; + } + if (errno == EWOULDBLOCK || errno == EAGAIN) + return -1; + scm_syserror ("fport_read"); } + return ret; +} + +static size_t +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; + + 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 ret; } 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; @@ -828,162 +664,69 @@ fport_truncate (SCM port, scm_t_off length) } 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; - } - } - } - - /* handle line buffering. */ - if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size)) - fport_flush (port); - } -} -#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; - pt->rw_active = SCM_PORT_NEITHER; -} - -/* 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"); - } - pt->rw_active = SCM_PORT_NEITHER; -} - -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 int 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); - fport_flush (port); - scm_dynwind_end (); - - scm_port_non_buffer (SCM_PTAB_ENTRY (port)); - - rv = close (fp->fdes); - if (rv) + 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/. Instead just throw an error if close fails, trusting that the fd was cleaned up. */ scm_syserror ("fport_close"); - - return 0; } -static size_t -fport_free (SCM port) +static int +fport_random_access_p (SCM port) { - fport_close (port); - return 0; + 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 scm_t_bits +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) +{ +#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_port_type * scm_make_fptob () { - scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write); + scm_t_port_type *ptob = scm_make_port_type ("file", fport_read, fport_write); - scm_set_port_free (tc, fport_free); - 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 (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_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); - return tc; + return ptob; } /* We can't initialize the keywords from 'scm_init_fports', because @@ -995,20 +738,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_file_port_type = 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)); + 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/fports.h b/libguile/fports.h index 092b43ee8..afb8ba771 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -31,29 +31,30 @@ /* 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_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)) -/* test whether fdes supports random access. */ -#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_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); @@ -73,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/frames.c b/libguile/frames.c index 2162f49ce..11d4f12ee 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) @@ -49,66 +41,49 @@ 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); + if (scm_module_system_booted_p) + { + SCM name = scm_frame_procedure_name (frame); + + if (scm_is_true (name)) + { + scm_putc (' ', port); + scm_write (name, port); + } + } + /* Don't write args, they can be ridiculously long. */ + scm_puts (">", 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 (); } } -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 (); - } -} - -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)); -} -#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)); - + return frame_stack_top (SCM_VM_FRAME_KIND (frame), + SCM_VM_FRAME_DATA (frame)); } #undef FUNC_NAME @@ -130,10 +105,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); @@ -141,16 +116,26 @@ 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, +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 +#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); - /* FIXME: Retrieve procedure from address? */ - return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame), - SCM_VM_FRAME_DATA (frame)); + return scm_call_1 (scm_variable_ref (frame_procedure_name_var), frame); } #undef FUNC_NAME @@ -209,12 +194,12 @@ 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 { - SCM *fp, *sp; + union scm_vm_stack_element *fp, *sp; SCM_VALIDATE_VM_FRAME (1, frame); @@ -225,45 +210,104 @@ 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, + STACK_ITEM_U64 = 2, + STACK_ITEM_S64 = 3 + }; + +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; + 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. */ +} + +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 { - SCM *fp, *sp; - unsigned int i; - - 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 -{ - SCM *fp, *sp; + 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)) { - 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 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(); + } + } + + SCM_OUT_OF_RANGE (SCM_ARG2, index); +} +#undef FUNC_NAME + +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; + 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); + break; + 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(); + } return SCM_UNSPECIFIED; } @@ -314,9 +358,6 @@ 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)) - SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, (SCM frame), "") @@ -326,43 +367,34 @@ 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 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); - if (!new_fp) - return 0; - - 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); - { - 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; } @@ -388,12 +420,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 31f86345f..ef2db3df5 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,29 @@ -/* 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 */ + scm_t_uintptr as_uint; + scm_t_uint32 *as_ip; + SCM as_scm; + double as_f64; + scm_t_uint64 as_u64; + scm_t_int64 as_s64; + + /* For GC purposes. */ + void *as_ptr; + scm_t_bits as_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].as_ip) +#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) ((fp)[0].as_ip = (ra)) +#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)) /* @@ -137,14 +136,12 @@ 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 scm_t_ptrdiff scm_i_frame_offset (SCM frame); +SCM_INTERNAL union scm_vm_stack_element* scm_i_frame_stack_top (SCM frame); /* See notes in frames.c before using this. */ SCM_INTERNAL SCM scm_c_frame_closure (enum scm_vm_frame_kind kind, @@ -159,13 +156,10 @@ 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); 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_address (SCM frame); SCM_API SCM scm_frame_stack_pointer (SCM frame); SCM_API SCM scm_frame_instruction_pointer (SCM frame); 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 13823c054..4478128c6 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 @@ -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" @@ -89,108 +88,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; @@ -208,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 @@ -496,22 +365,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_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))); - protected_obj_count ++; - - SCM_CRITICAL_SECTION_END; + + scm_dynwind_end (); return obj; } @@ -526,18 +394,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_i_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 +413,7 @@ scm_gc_unprotect_object (SCM obj) } protected_obj_count --; - SCM_CRITICAL_SECTION_END; + scm_dynwind_end (); return obj; } @@ -608,6 +468,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); @@ -679,46 +545,15 @@ 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 - * 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->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; } 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/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 " 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/libguile/generalized-vectors.c b/libguile/generalized-vectors.c index fc493bc80..276b9d865 100644 --- a/libguile/generalized-vectors.c +++ b/libguile/generalized-vectors.c @@ -69,24 +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) - - void scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h) { @@ -98,24 +80,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); diff --git a/libguile/goops.c b/libguile/goops.c index 1f7ec90c8..a158a1cab 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" @@ -50,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 @@ -114,6 +110,8 @@ 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; static SCM class_foreign_slot; @@ -128,7 +126,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; @@ -137,11 +134,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]; @@ -236,6 +228,10 @@ 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: return class_vm_cont; case scm_tc7_bytevector: @@ -276,11 +272,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. */ @@ -477,6 +478,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.") @@ -489,7 +492,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); @@ -499,7 +502,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 @@ -512,7 +515,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); @@ -524,7 +527,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 @@ -758,40 +761,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 @@ -842,7 +872,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. */ @@ -975,6 +1005,8 @@ 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 ("")); class_uvec = scm_variable_ref (scm_c_lookup ("")); @@ -985,7 +1017,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/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/gsubr.c b/libguile/gsubr.c index 329241da2..e22d16363 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 @@ -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) @@ -251,48 +265,71 @@ create_subr (int define, const char *name, return ret; } -/* 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) +scm_i_primitive_code_p (const scm_t_uint32 *code) { - 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))) 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) { + 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 +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 diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 065b94766..83eebc371 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 @@ -54,9 +54,13 @@ -SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest); +SCM_INTERNAL int scm_i_primitive_code_p (const scm_t_uint32 *code); 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/guardians.c b/libguile/guardians.c index 86e39ee54..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" @@ -86,16 +85,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/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); 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 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/libguile/hashtab.c b/libguile/hashtab.c index 30d781fe7..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" @@ -168,14 +167,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 782636e4e..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" @@ -134,22 +133,22 @@ static int 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/i18n.c b/libguile/i18n.c index f0e344329..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 @@ -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-localeinteger", 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, @@ -1417,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, @@ -1605,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: @@ -1618,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/libguile/init.c b/libguile/init.c index dd63574fd..b046685d4 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -35,8 +35,8 @@ /* 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" #include "libguile/bitvectors.h" #include "libguile/boolean.h" @@ -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" @@ -123,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" @@ -343,7 +345,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. */ @@ -397,7 +399,8 @@ scm_i_init_guile (void *base) scm_bootstrap_loader (); scm_bootstrap_programs (); scm_bootstrap_vm (); - scm_register_r6rs_ports (); + scm_register_atomic (); + scm_register_fdes_finalizers (); scm_register_foreign (); scm_register_foreign_object (); scm_register_srfi_1 (); @@ -409,13 +412,10 @@ 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_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 (); @@ -430,9 +430,10 @@ scm_i_init_guile (void *base) scm_init_control (); /* requires fluids */ scm_init_feature (); scm_init_backtrace (); + scm_init_ports (); + scm_register_r6rs_ports (); /* requires ports */ scm_init_fports (); scm_init_strports (); - scm_init_ports (); scm_init_hash (); scm_init_hashtab (); scm_init_deprecation (); @@ -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/instructions.c b/libguile/instructions.c index e474cf5d5..29e60983b 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -31,33 +31,43 @@ 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(AF32) /* Immediate double, high bits. */ \ + 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(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 +#define TYPE_WIDTH 6 enum word_type { @@ -73,19 +83,19 @@ 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 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) \ @@ -99,28 +109,32 @@ 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 */ 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; /* 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/ioext.c b/libguile/ioext.c index 659eabcf5..4038fd54f 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -29,11 +29,13 @@ #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" #include "libguile/ioext.h" #include "libguile/ports.h" +#include "libguile/ports-internal.h" #include "libguile/strings.h" #include "libguile/validate.h" @@ -86,20 +88,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); - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (new); + /* Ensure there is nothing in either port's input or output + buffers. */ + if (SCM_OUTPUT_PORT_P (old)) + scm_flush (old); + 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 (new)->rw_random) + scm_end_input (new); - /* must flush to old fdes. */ - if (pt->rw_active == SCM_PORT_WRITE) - ptob->flush (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_PORT (new)->rw_random = SCM_PORT (old)->rw_random; } return SCM_UNSPECIFIED; } @@ -221,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 @@ -262,6 +268,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; } @@ -271,10 +278,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; @@ -299,12 +304,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/keywords.c b/libguile/keywords.c index 49cccd5a5..087042b84 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" @@ -63,7 +62,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_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); @@ -72,7 +72,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 @@ -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/list.c b/libguile/list.c index 27ac22f2b..939631531 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); @@ -395,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; } @@ -458,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; @@ -504,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/load.c b/libguile/load.c index 74f3bb49b..7b8136af8 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -28,18 +28,18 @@ #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/srfi-13.h" +#include "libguile/strings.h" +#include "libguile/throw.h" #include "libguile/validate.h" #include "libguile/load.h" @@ -541,13 +541,253 @@ 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 (";;; note: source file ", scm_current_warning_port ()); + scm_display (full_filename, scm_current_warning_port ()); + scm_puts ("\n;;; newer than compiled ", scm_current_warning_port ()); + scm_display (compiled_filename, scm_current_warning_port ()); + scm_puts ("\n", scm_current_warning_port ()); + } + + 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. 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. + */ static SCM search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, struct stat *stat_buf) @@ -754,35 +994,6 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, #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 +1006,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 (";;; 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 +1035,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 (";;; 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 ("\n;;; is part of the compiler; skipping auto-compilation\n", - scm_current_error_port ()); + scm_puts (";;; it seems ", scm_current_warning_port ()); + scm_display (source, scm_current_warning_port ()); + scm_puts ("\n;;; is part of the compiler; skipping auto-compilation\n", + scm_current_warning_port ()); return SCM_BOOL_F; } } @@ -848,16 +1059,16 @@ auto_compile_catch_handler (void *data, SCM tag, SCM throw_args) oport = scm_open_output_string (); scm_print_exception (oport, SCM_BOOL_F, tag, throw_args); - scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_warning_port ()); + scm_puts (";;; WARNING: compilation of ", scm_current_warning_port ()); scm_display (source, scm_current_warning_port ()); - scm_puts_unlocked (" failed:\n", 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_unlocked (";;; ", scm_current_warning_port ()); + scm_puts (";;; ", scm_current_warning_port ()); scm_display (scm_car (lines), scm_current_warning_port ()); scm_newline (scm_current_warning_port ()); } @@ -875,7 +1086,7 @@ SCM_DEFINE (scm_sys_warn_auto_compilation_enabled, "%warn-auto-compilation-enabl if (!message_shown) { - scm_puts_unlocked (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n" + scm_puts (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n" ";;; or pass the --no-auto-compile argument to disable.\n", scm_current_warning_port ()); message_shown = 1; @@ -945,10 +1156,10 @@ 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; - int compiled_is_fallback = 0; + SCM full_filename, compiled_thunk; 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", @@ -984,12 +1195,10 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, *scm_loc_load_extensions, SCM_BOOL_F, &stat_source); - compiled_filename = - search_path (*scm_loc_load_compiled_path, filename, - *scm_loc_load_compiled_extensions, SCM_BOOL_T, - &stat_compiled); + 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) @@ -1005,15 +1214,23 @@ 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)) { - compiled_filename = fallback; - compiled_is_fallback = 1; + if (found_stale_compiled_file) + { + scm_puts (";;; found fresh local cache at ", + scm_current_warning_port ()); + scm_display (fallback, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); + } + 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); @@ -1025,56 +1242,19 @@ 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_false (full_filename) - || (scm_is_true (compiled_filename) - && compiled_is_fresh (full_filename, compiled_filename, - &stat_source, &stat_compiled))) - 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))) + if (scm_is_true (compiled_thunk)) + return scm_call_0 (compiled_thunk); + 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_call_0 (scm_load_thunk_from_file (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 @@ -1087,22 +1267,22 @@ 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); - 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_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_scm) && scm_is_true (eval_go) - && compiled_is_fresh (eval_scm, eval_go, - &stat_source, &stat_compiled)) - 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 */ + /* 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; } diff --git a/libguile/loader.c b/libguile/loader.c index a55bd15b0..54bf1bff5 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 @@ -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 @@ -208,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; @@ -292,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: @@ -416,7 +418,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. */ @@ -429,7 +442,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 +477,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" @@ -478,7 +489,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); @@ -489,15 +500,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); @@ -510,11 +521,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; } @@ -748,7 +759,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; @@ -794,6 +805,11 @@ scm_find_dead_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); 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/macros.c b/libguile/macros.c index 47b252d85..94421c17a 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -49,11 +49,11 @@ static int macro_print (SCM macro, SCM port, scm_print_state *pstate) { if (scm_is_false (SCM_MACRO_TYPE (macro))) - scm_puts_unlocked ("#', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 9f3584a09..23c1a6079 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/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/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; -} 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, 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 */ diff --git a/libguile/numbers.c b/libguile/numbers.c index 14d98ffea..3e0efc8bb 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-2016 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -64,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" @@ -89,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 @@ -274,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; } @@ -1173,9 +1166,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 +1542,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 +1576,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 +1609,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 +1619,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 +2079,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 +2124,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 +2157,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 +2167,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 +2558,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 +2575,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 +2609,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 +2621,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 +3195,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 +3250,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 +3867,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 +3921,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 @@ -5654,7 +5619,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)) { @@ -5671,13 +5636,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); @@ -5692,7 +5657,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 +5665,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 +5673,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 +5681,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 +5702,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; } @@ -8052,17 +8017,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))) @@ -8087,10 +8041,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)); @@ -9023,8 +8986,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 @@ -9140,6 +9103,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); @@ -9672,6 +9637,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; @@ -9679,18 +9645,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; } @@ -9982,7 +9952,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))) 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)) 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/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..121a76518 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -176,6 +176,30 @@ 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) +{ + /* 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/poll.c b/libguile/poll.c index 9ea846b6d..a17ca4148 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" @@ -106,13 +107,16 @@ 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 *pt = SCM_PORT (port); + size_t tmp; - if (pt->read_pos < pt->read_end) + if (scm_port_buffer_can_take (pt->read_buf, &tmp) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; - if (pt->write_pos < pt->write_end) - /* Buffered output possible. */ + if (SCM_OUTPUT_PORT_P (port) + && 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; } } @@ -142,13 +146,16 @@ 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 *pt = SCM_PORT (port); + size_t tmp; - if (pt->read_pos < pt->read_end) + 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) && pt->write_pos < pt->write_end) - /* Buffered output possible. */ + if (SCM_OUTPUT_PORT_P (port) + && 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 bff89cb5e..be7ba60f5 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -22,45 +22,353 @@ #ifndef SCM_PORTS_INTERNAL #define SCM_PORTS_INTERNAL +#include +#include + #include "libguile/_scm.h" #include "libguile/ports.h" -enum scm_port_encoding_mode { - SCM_PORT_ENCODING_MODE_UTF8, - SCM_PORT_ENCODING_MODE_LATIN1, - SCM_PORT_ENCODING_MODE_ICONV +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_port_type +{ + 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; + + 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); + + 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; + + /* GOOPS tomfoolery. */ + SCM input_class, output_class, input_output_class; }; -typedef enum scm_port_encoding_mode scm_t_port_encoding_mode; +/* Port buffers. -/* This is a separate object so that only those ports that use iconv - cause finalizers to be registered. */ -struct scm_iconv_descriptors -{ - /* input/output iconv conversion descriptors */ - void *input_cd; - void *output_cd; + 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_POSITION, + SCM_PORT_BUFFER_FIELD_COUNT }; -typedef struct scm_iconv_descriptors scm_t_iconv_descriptors; +/* 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. */ -struct scm_port_internal +static inline SCM +scm_port_buffer_bytevector (SCM buf) { - 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; - int pending_eof; + 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); +} + +/* 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) +{ + 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 buf) +{ + 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 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 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 (end > scm_port_buffer_size (buf)) + scm_misc_error (NULL, "invalid port buffer ~a", scm_list_1 (buf)); + /* 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, 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; +} + +static inline size_t +scm_port_buffer_can_putback (SCM buf) +{ + 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 ~a", scm_list_1 (buf)); + return cur; +} + +static inline void +scm_port_buffer_did_take (SCM buf, size_t prev_cur, size_t 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 prev_end, size_t 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, size_t cur) +{ + signed char *ret = SCM_BYTEVECTOR_CONTENTS (scm_port_buffer_bytevector (buf)); + return ((scm_t_uint8 *) ret) + cur; +} + +static inline scm_t_uint8 * +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) + end; +} + +static inline size_t +scm_port_buffer_take (SCM buf, scm_t_uint8 *dst, size_t count, + size_t cur, size_t avail) +{ + if (avail < count) + count = avail; + if (dst) + 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, + size_t end, size_t avail) +{ + if (avail < count) + count = avail; + if (src) + 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, + size_t cur) +{ + assert (count <= cur); + + /* Sometimes used to move around data within a buffer, so we must use + memmove. */ + 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); +} + +struct scm_t_port +{ + /* Source location information. */ + SCM file_name; + SCM position; + + /* 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 + 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; + + /* 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. */ + 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. */ + SCM conversion_strategy; /* A symbol; either substitute, error, or escape. */ + + /* 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; }; -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_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_t_port_rw_active mode); +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 98d2fa219..2a25cd58e 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 @@ -28,19 +27,20 @@ # include #endif +#include #include #include #include /* for chsize on mingw */ #include #include +#include #include #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 */ @@ -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" @@ -91,261 +90,304 @@ #endif -/* 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, const char *upper) -{ - if (!enc) - enc = "ISO-8859-1"; +/* 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; - while (*enc) - if (ascii_toupper (*enc++) != *upper++) - return 0; +/* Port conversion strategies. */ +static SCM sym_error; +static SCM sym_substitute; +static SCM sym_escape; - return !*upper; -} +/* See scm_port_auxiliary_write_buffer and scm_c_write. */ +static const size_t AUXILIARY_WRITE_BUFFER_SIZE = 256; -static char* -canonicalize_encoding (const char *enc) -{ - char *ret; - int i; +/* Maximum number of bytes in a UTF-8 sequence. */ +static const size_t UTF8_BUFFER_SIZE = 4; - if (!enc) - return "ISO-8859-1"; - - 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 ret; -} +/* Maximum number of codepoints to write an escape sequence. */ +static const size_t ESCAPE_BUFFER_SIZE = 9; -/* The port kind table --- a dynamically resized array of port types. */ +/* We have to serialize operations on any given iconv descriptor. */ +static scm_i_pthread_mutex_t iconv_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; -/* 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) +/* See Unicode 8.0 section 5.22, "Best Practice for U+FFFD + Substitution". */ +static const scm_t_wchar UNICODE_REPLACEMENT_CHARACTER = 0xFFFD; + + + +static void +release_port (SCM port) { - long ret; - - scm_i_pthread_mutex_lock (&scm_ptobs_lock); - ret = scm_numptob; - scm_i_pthread_mutex_unlock (&scm_ptobs_lock); + scm_t_port *pt = SCM_PORT (port); - 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) + /* 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 (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; + if (cur == 0) + return; + next = cur - 1; } - - scm_i_pthread_mutex_unlock (&scm_ptobs_lock); + if (cur > 1) + return; - if (ret < 0) - scm_out_of_range ("scm_c_port_type_add_x", scm_from_long (scm_numptob)); + /* 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); - 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) -{ + 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 -end_input_default (SCM port SCM_UNUSED, int offset SCM_UNUSED) +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); } -scm_t_bits + + +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_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, - int (*fill_input) (SCM port), - void (*write) (SCM port, const void *data, size_t size)) + 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)); desc->name = name; desc->print = scm_port_print; - desc->write = write; - desc->flush = flush_port_default; - desc->end_input = end_input_default; - desc->fill_input = fill_input; + 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; + 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); - ptobnum = scm_c_port_type_add_x (desc); + return desc; +} - /* Make a class object if GOOPS is present. */ - if (SCM_UNPACK (scm_i_port_class[0]) != 0) - scm_make_port_classes (ptobnum, 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, ret; - return scm_tc7_port + ptobnum * 256; + 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 (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); +} +#undef FUNC_NAME + +static size_t +trampoline_to_scm_read (SCM port, SCM dst, size_t start, 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, 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 (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); +} +#undef FUNC_NAME + +static size_t +trampoline_to_scm_write (SCM port, SCM src, size_t start, 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 -scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM)) +scm_set_port_scm_read (scm_t_port_type *ptob, SCM read) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->mark = mark; + ptob->scm_read = read; + ptob->c_read = trampoline_to_scm_read; } void -scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM)) +scm_set_port_scm_write (scm_t_port_type *ptob, SCM write) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->free = free; + 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_read_wait_fd (scm_t_port_type *ptob, int (*get_fd) (SCM)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->print = print; + ptob->read_wait_fd = get_fd; } void -scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) +scm_set_port_write_wait_fd (scm_t_port_type *ptob, int (*get_fd) (SCM)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->equalp = equalp; + ptob->write_wait_fd = get_fd; } void -scm_set_port_close (scm_t_bits tc, int (*close) (SCM)) +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))->close = close; + ptob->print = print; } void -scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)) +scm_set_port_close (scm_t_port_type *ptob, void (*close) (SCM)) { - scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); - ptob->flush = flush; - ptob->flags |= SCM_PORT_TYPE_HAS_FLUSH; + ptob->close = close; } void -scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset)) +scm_set_port_needs_close_on_gc (scm_t_port_type *ptob, int needs_close_p) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->end_input = end_input; + 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_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_setvbuf (scm_t_bits tc, void (*setvbuf) (SCM, long, long)) +scm_set_port_random_access_p (scm_t_port_type *ptob, + int (*random_access_p) (SCM)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->setvbuf = setvbuf; + ptob->random_access_p = random_access_p; } -static void -scm_i_set_pending_eof (SCM port) +void +scm_set_port_get_natural_buffer_sizes + (scm_t_port_type *ptob, + void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)) { - SCM_PORT_GET_INTERNAL (port)->pending_eof = 1; + ptob->get_natural_buffer_sizes = get_natural_buffer_sizes; } static void scm_i_clear_pending_eof (SCM port) { - SCM_PORT_GET_INTERNAL (port)->pending_eof = 0; + scm_port_buffer_set_has_eof_p (SCM_PORT (port)->read_buf, + SCM_BOOL_F); } SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, @@ -353,15 +395,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_i_pthread_mutex_t *lock; - SCM result; - 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); - return result; + + return scm_assq_ref (SCM_PORT (port)->alist, key); } #undef FUNC_NAME @@ -370,15 +406,13 @@ 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_PORT (port); + pt->alist = scm_assq_set_x (pt->alist, key, value); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -457,14 +491,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); @@ -473,11 +502,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); @@ -487,11 +514,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); @@ -501,7 +526,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" @@ -514,7 +538,6 @@ scm_set_current_warning_port (SCM port) } #undef FUNC_NAME - void scm_dynwind_current_input_port (SCM port) #define FUNC_NAME NULL @@ -551,6 +574,25 @@ scm_i_dynwind_current_load_port (SCM port) } + + +/* Port buffers. */ + +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; +} + + /* Retrieving a port's mode. */ @@ -564,9 +606,8 @@ scm_i_dynwind_current_load_port (SCM port) 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) @@ -639,22 +680,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. */ @@ -668,16 +697,9 @@ 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_SET_PORT_FINALIZING (port); + scm_internal_catch (SCM_BOOL_T, do_close, ptr, scm_handle_by_message_noexit, NULL); - scm_gc_ports_collected++; } } @@ -685,83 +707,94 @@ 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) +{ + scm_t_port *pt = SCM_PORT (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) + 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 = 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 -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_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 *entry; - scm_t_port_internal *pti; - scm_t_ptob_descriptor *ptob; + scm_t_port *pt; - entry = scm_gc_typed_calloc (scm_t_port); - pti = scm_gc_typed_calloc (scm_t_port_internal); - ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag)); + pt = scm_gc_typed_calloc (scm_t_port); - 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 (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); - entry->lock = scm_gc_malloc_pointerless (sizeof (*entry->lock), "port lock"); - scm_i_pthread_mutex_init (entry->lock, scm_i_pthread_mutexattr_recursive); + pt->encoding = encoding; + pt->conversion_strategy = conversion_strategy; + pt->file_name = SCM_BOOL_F; + pt->position = scm_cons (SCM_INUM0, SCM_INUM0); - entry->internal = pti; - entry->file_name = SCM_BOOL_F; - entry->rw_active = SCM_PORT_NEITHER; - entry->port = ret; - entry->stream = stream; + pt->refcount = 1; - if (encoding_matches (encoding, "UTF-8")) + 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) { - 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); + scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL); + scm_weak_set_add_x (scm_i_port_weak_set, ret); } - entry->ilseq_handler = handler; - pti->iconv_descriptors = NULL; + initialize_port_buffers (ret); - 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)->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); + pt->rw_random = ptob->random_access_p (ret); return ret; } 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_handler (), + 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. */ @@ -826,12 +859,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" @@ -842,37 +869,24 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, "descriptors.") #define FUNC_NAME s_scm_close_port { - scm_t_port_internal *pti; - int rv; - port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_PORT (1, port); + if (SCM_CLOSEDP (port)) return SCM_BOOL_F; - pti = SCM_PORT_GET_INTERNAL (port); + /* May throw an exception. */ + if (SCM_OUTPUT_PORT_P (port)) + scm_flush (port); + SCM_CLR_PORT_OPEN_FLAG (port); - if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_HAS_FLUSH) + 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) - /* 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; + release_port (port); - if (pti->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; - } - - return scm_from_bool (rv >= 0); + return SCM_BOOL_T; } #undef FUNC_NAME @@ -913,144 +927,119 @@ 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. */ -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")) + 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. */ -const char * +SCM 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))) - return "ISO-8859-1"; - else - { - SCM encoding; + 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); - } + encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var)); + if (!scm_is_string (encoding)) + return sym_ISO_8859_1; + else + 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. */ -SCM_VARIABLE (default_conversion_strategy_var, - "%default-port-conversion-strategy"); - -/* Whether the above fluid is initialized. */ -static int scm_conversion_strategy_init = 0; - -/* The possible conversion strategies. */ -SCM_SYMBOL (sym_error, "error"); -SCM_SYMBOL (sym_substitute, "substitute"); -SCM_SYMBOL (sym_escape, "escape"); +static SCM default_conversion_strategy_var; /* 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_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; - else - { - SCM fluid, value; + value = scm_fluid_ref (SCM_VARIABLE_REF (default_conversion_strategy_var)); - fluid = SCM_VARIABLE_REF (default_conversion_strategy_var); - value = scm_fluid_ref (fluid); + if (scm_is_eq (sym_substitute, value) || scm_is_eq (sym_escape, value)) + return value; - 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 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 (); - 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: - 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); -} - -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 -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]) - { - pt->read_pos++; - i++; - } - scm_i_unget_bytes_unlocked (bytes, i, port); - return (i == len); + scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var), sym); } static const unsigned char scm_utf8_bom[3] = {0xEF, 0xBB, 0xBF}; @@ -1059,83 +1048,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}; -/* 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 const char * -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"; - else - return "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 * -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"; - else - return "UTF-32BE"; -} - +/* 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 (const char *encoding, int reading, int writing) -{ - 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) { @@ -1145,145 +1104,161 @@ open_iconv_descriptors (const char *encoding, int reading, int writing) } } - id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors"); - 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 err; - err = scm_from_latin1_string (encoding); - scm_misc_error ("open_iconv_descriptors", - "invalid or unknown character encoding ~s", - scm_list_1 (err)); - } + 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) +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 { - 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; -} + SCM_VALIDATE_PORT (1, port); + SCM_VALIDATE_SYMBOL (2, encoding); -scm_t_iconv_descriptors * -scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode) -{ - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - - assert (pti->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV); - - if (!pti->iconv_descriptors) + if (scm_is_eq (SCM_PORT (port)->encoding, sym_UTF_16)) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - const char *precise_encoding; - - if (!pt->encoding) - pt->encoding = "ISO-8859-1"; - - /* 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) - precise_encoding = decide_utf16_encoding (port, mode); - else if (strcmp (pt->encoding, "UTF-32") == 0) - precise_encoding = decide_utf32_encoding (port, mode); - else - precise_encoding = pt->encoding; - - pti->iconv_descriptors = - open_iconv_descriptors (precise_encoding, - SCM_INPUT_PORT_P (port), - SCM_OUTPUT_PORT_P (port)); + 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_PORT (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); - return pti->iconv_descriptors; + 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 + +/* 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); + + 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; +} + +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_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; + 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 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); - 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; - } - - pti->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_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); + SCM_VALIDATE_OPPORT (1, port); - return scm_from_latin1_string (SCM_PTAB_ENTRY (port)->encoding); + return SCM_PORT (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_OPPORT (1, port); + SCM_VALIDATE_SYMBOL (2, enc); - SCM_VALIDATE_PORT (1, port); - SCM_VALIDATE_STRING (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) +{ + 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" @@ -1299,31 +1274,11 @@ 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 (); - else - { - scm_t_port *pt; + return scm_i_default_port_conversion_strategy (); - SCM_VALIDATE_OPPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - - h = pt->ilseq_handler; - } - - 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; + SCM_VALIDATE_OPPORT (1, port); + return SCM_PORT (port)->conversion_strategy; } #undef FUNC_NAME @@ -1347,23 +1302,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_PORT (port)->conversion_strategy = sym; } return SCM_UNSPECIFIED; @@ -1373,32 +1322,117 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", -/* The port lock. */ +/* Non-blocking I/O. */ -static void -lock_port (void *mutex) +static int +port_read_wait_fd (SCM port) { - scm_i_pthread_mutex_lock ((scm_i_pthread_mutex_t *) mutex); + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + return ptob->read_wait_fd (port); } -static void -unlock_port (void *mutex) +static int +port_write_wait_fd (SCM port) { - scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *) mutex); + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + return ptob->write_wait_fd (port); } -void -scm_dynwind_lock_port (SCM port) -#define FUNC_NAME "dynwind-lock-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 { - scm_i_pthread_mutex_t *lock; - SCM_VALIDATE_OPPORT (SCM_ARG1, port); - scm_c_lock_port (port, &lock); - if (lock) + 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 + +/* Call while having acquired the port. */ +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) { - scm_dynwind_unwind_handler (unlock_port, lock, SCM_F_WIND_EXPLICITLY); - scm_dynwind_rewind_handler (lock_port, lock, 0); + 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; + SCM ret; + + 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; + + 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 @@ -1407,220 +1441,274 @@ scm_dynwind_lock_port (SCM port) /* Input. */ +static int +get_byte_or_eof (SCM port) +{ + SCM buf = SCM_PORT (port)->read_buf; + SCM buf_bv, buf_cur, buf_end; + size_t 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_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, 0, &cur, &avail); + buf_bv = scm_port_buffer_bytevector (buf); + if (avail > 0) + { + 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_out, size_t *cur_out) +{ + SCM buf = SCM_PORT (port)->read_buf; + SCM buf_bv, buf_cur, buf_end; + size_t 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 (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_out = buf; + *cur_out = cur; + return ret; + } + + buf = scm_fill_input (port, 0, &cur, &avail); + buf_bv = scm_port_buffer_bytevector (buf); + *buf_out = buf; + *cur_out = cur; + if (avail > 0) + { + 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; + SCM buf; + size_t cur; + return peek_byte_or_eof (port, &buf, &cur); } -/* 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! */ - -/* 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 +static size_t +scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) { - scm_t_port *pt; - unsigned char *buffer; - size_t size; -}; + size_t filled; + scm_t_port_type *ptob = SCM_PORT_TYPE (port); -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; + assert (count <= SCM_BYTEVECTOR_LENGTH (dst)); + assert (start + count <= SCM_BYTEVECTOR_LENGTH (dst)); - /* 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; + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); - /* Save the port's old (buffer, size) in the struct. */ - psb->buffer = old_buf; - psb->size = old_size; + retry: + filled = ptob->c_read (port, dst, start, count); + + if (filled == (size_t) -1) + { + port_poll (port, POLLIN, -1); + goto retry; + } + + scm_dynwind_end (); + + assert (filled <= count); + + return filled; } -static int scm_i_fill_input_unlocked (SCM port); +/* 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); +/* 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! */ size_t -scm_c_read_unlocked (SCM port, void *buffer, size_t size) -#define FUNC_NAME "scm_c_read" +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; - size_t n_read = 0, n_available; - struct port_and_swap_buffer psb; + 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); - pti = SCM_PORT_GET_INTERNAL (port); - if (pt->rw_active == SCM_PORT_WRITE) - SCM_PORT_DESCRIPTOR (port)->flush (port); + pt = SCM_PORT (port); + read_buf = pt->read_buf; if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + scm_flush (port); + + port_clear_stream_start_for_bom_read (port, BOM_IO_BINARY); /* Take bytes first from the port's read buffer. */ - if (pt->read_pos < pt->read_end) + { + 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; + } + + while (to_read) { - 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 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 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) + { + /* Consider that we've read off this EOF. */ + scm_port_buffer_set_has_eof_p (read_buf, SCM_BOOL_F); + break; + } + } + else + { + 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) + break; + } } - /* Avoid the scm_dynwind_* costs if we now have enough data. */ - if (size == 0) - return n_read; - - /* 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 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 (SCM port, void *buffer, size_t size) +#define FUNC_NAME "scm_c_read" { - scm_i_pthread_mutex_t *lock; - size_t ret; + size_t copied = 0; + scm_t_port *pt; + SCM read_buf; + scm_t_uint8 *dst = buffer; - scm_c_lock_port (port, &lock); - ret = scm_c_read_unlocked (port, buffer, size); - if (lock) - scm_i_pthread_mutex_unlock (lock); - + SCM_VALIDATE_OPINPORT (1, port); - return ret; + pt = SCM_PORT (port); + read_buf = pt->read_buf; + + if (pt->rw_random) + scm_flush (port); + + while (copied < size) + { + 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) + { + /* Consider that we've read off this EOF. */ + scm_port_buffer_set_has_eof_p (read_buf, SCM_BOOL_F); + break; + } + } + + return copied; } +#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) +update_port_position (SCM position, scm_t_wchar c) { + 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); + { + 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_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; } } -#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 @@ -1630,25 +1718,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 @@ -1658,325 +1746,253 @@ 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. */ -static int -get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, - scm_t_uint8 buf[SCM_MBCHAR_BUF_SIZE], 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, SCM *buf_out, size_t *cur_out, size_t *len_out) { -#define ASSERT_NOT_EOF(b) \ - if (SCM_UNLIKELY ((b) == EOF)) \ - goto invalid_seq -#define CONSUME_PEEKED_BYTE() \ - pt->read_pos++ +#define DECODING_ERROR(bytes) \ + do { *buf_out = buf; *cur_out = cur; *len_out = bytes; goto decoding_error; } while (0) +#define RETURN(bytes, codepoint) \ + do { *buf_out = buf; *cur_out = cur; *len_out = bytes; return codepoint; } while (0) - int byte; - scm_t_port *pt; + SCM buf; + size_t cur, avail; + int first_byte; + const scm_t_uint8 *ptr; - *len = 0; - pt = SCM_PTAB_ENTRY (port); - - byte = scm_get_byte_or_eof_unlocked (port); - if (byte == EOF) + 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) { - *codepoint = EOF; - return 0; + buf = scm_fill_input (port, 2, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); + + if (avail < 2 || (ptr[1] & 0xc0) != 0x80) + DECODING_ERROR (1); + + RETURN (2, (first_byte & 0x1f) << 6UL | (ptr[1] & 0x3f)); } - - 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 & 0xf0) == 0xe0) { - /* 2-byte form. */ - byte = scm_peek_byte_or_eof_unlocked (port); - ASSERT_NOT_EOF (byte); + buf = scm_fill_input (port, 3, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); - if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) - goto invalid_seq; + if (avail < 2 || (ptr[1] & 0xc0) != 0x80 + || (ptr[0] == 0xe0 && ptr[1] < 0xa0) + || (ptr[0] == 0xed && ptr[1] > 0x9f)) + DECODING_ERROR (1); - CONSUME_PEEKED_BYTE (); - buf[1] = (scm_t_uint8) byte; - *len = 2; + if (avail < 3 || (ptr[2] & 0xc0) != 0x80) + DECODING_ERROR (2); - *codepoint = ((scm_t_wchar) buf[0] & 0x1f) << 6UL - | (buf[1] & 0x3f); + RETURN (3, + ((scm_t_wchar) ptr[0] & 0x0f) << 12UL + | ((scm_t_wchar) ptr[1] & 0x3f) << 6UL + | (ptr[2] & 0x3f)); } - else if ((buf[0] & 0xf0) == 0xe0) + else if (first_byte >= 0xf0 && first_byte <= 0xf4) { - /* 3-byte form. */ - byte = scm_peek_byte_or_eof_unlocked (port); - ASSERT_NOT_EOF (byte); + buf = scm_fill_input (port, 4, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); - if (SCM_UNLIKELY ((byte & 0xc0) != 0x80 - || (buf[0] == 0xe0 && byte < 0xa0) - || (buf[0] == 0xed && byte > 0x9f))) - goto invalid_seq; + if (avail < 2 || (ptr[1] & 0xc0) != 0x80 + || (ptr[0] == 0xf0 && ptr[1] < 0x90) + || (ptr[0] == 0xf4 && ptr[1] > 0x8f)) + DECODING_ERROR (1); - CONSUME_PEEKED_BYTE (); - buf[1] = (scm_t_uint8) byte; - *len = 2; + if (avail < 3 || (ptr[2] & 0xc0) != 0x80) + DECODING_ERROR (2); - byte = scm_peek_byte_or_eof_unlocked (port); - ASSERT_NOT_EOF (byte); + if (avail < 4 || (ptr[3] & 0xc0) != 0x80) + DECODING_ERROR (3); - 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); - } - else if (buf[0] >= 0xf0 && buf[0] <= 0xf4) - { - /* 4-byte form. */ - byte = scm_peek_byte_or_eof_unlocked (port); - ASSERT_NOT_EOF (byte); - - if (SCM_UNLIKELY (((byte & 0xc0) != 0x80) - || (buf[0] == 0xf0 && byte < 0x90) - || (buf[0] == 0xf4 && byte > 0x8f))) - goto invalid_seq; - - CONSUME_PEEKED_BYTE (); - buf[1] = (scm_t_uint8) byte; - *len = 2; - - byte = scm_peek_byte_or_eof_unlocked (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; - - byte = scm_peek_byte_or_eof_unlocked (port); - ASSERT_NOT_EOF (byte); - - if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) - goto invalid_seq; - - CONSUME_PEEKED_BYTE (); - buf[3] = (scm_t_uint8) byte; - *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 (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 - goto invalid_seq; + DECODING_ERROR (1); + decoding_error: + if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) + /* *len already set. */ + return UNICODE_REPLACEMENT_CHARACTER; + + scm_decoding_error ("peek-char", EILSEQ, "input decoding error", port); + /* Not reached. */ 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 +#undef DECODING_ERROR +#undef RETURN } -/* 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) +/* 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, SCM *buf, size_t *cur, size_t *len) { - *codepoint = scm_get_byte_or_eof_unlocked (port); + scm_t_wchar ret = peek_byte_or_eof (port, buf, cur); - if (*codepoint == EOF) - *len = 0; - else - { - *len = 1; - buf[0] = *codepoint; - } - return 0; + *len = ret == EOF ? 0 : 1; + + return ret; } -/* Likewise, read a byte sequence from PORT, passing it through its - input conversion descriptor. */ -static int -get_iconv_codepoint (SCM port, scm_t_wchar *codepoint, - char buf[SCM_MBCHAR_BUF_SIZE], size_t *len) +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 { - scm_t_iconv_descriptors *id; - scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE]; - size_t input_size = 0; + char *input, *output; + 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; - id = scm_i_port_iconv_descriptors (port, SCM_PORT_READ); + 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); - for (;;) + input = (char *) SCM_BYTEVECTOR_CONTENTS (bv) + c_start; + input_left = c_count; + output = (char *) utf8_buf; + output_left = sizeof (utf8_buf); + + /* FIXME: locking! */ + 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) { - int byte_read; - char *input, *output; - size_t input_left, output_left, done; - - byte_read = scm_get_byte_or_eof_unlocked (port); - if (SCM_UNLIKELY (byte_read == EOF)) - { - if (SCM_LIKELY (input_size == 0)) - { - *codepoint = (scm_t_wchar) EOF; - *len = input_size; - return 0; - } - else - { - /* EOF found in the middle of a multibyte character. */ - scm_i_set_pending_eof (port); - return EILSEQ; - } - } - - buf[input_size++] = byte_read; - - input = buf; - input_left = input_size; - output = (char *) utf8_buf; - output_left = sizeof (utf8_buf); - - done = iconv (id->input_cd, &input, &input_left, &output, &output_left); - - if (done == (size_t) -1) - { - int err = errno; - if (SCM_LIKELY (err == EINVAL)) - /* The input byte sequence did not form a complete - character. Read another byte and try again. */ - continue; - else - return err; - } + 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_PORT (port)->conversion_strategy, + sym_substitute)) + return SCM_MAKE_CHAR (UNICODE_REPLACEMENT_CHARACTER); 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; - } - } + 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 + `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, 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)) + { + size_t avail; + *buf = scm_fill_input (port, input_size + 1, cur, &avail); + + if (avail <= input_size) + { + *len = input_size; + if (input_size == 0) + /* Normal 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_port_acquire_iconv_descriptors (port, NULL, NULL); + scm_port_release_iconv_descriptors (port); + return EOF; + } + + /* EOF found in the middle of a multibyte character. */ + if (scm_is_eq (SCM_PORT (port)->conversion_strategy, + sym_substitute)) + return UNICODE_REPLACEMENT_CHARACTER; + + scm_decoding_error ("peek-char", EILSEQ, + "input decoding error", port); + /* Not reached. */ + return 0; + } + + input_size++; + maybe_char = scm_port_decode_char (port, + scm_port_buffer_bytevector (*buf), + SCM_I_MAKINUM (*cur), + SCM_I_MAKINUM (input_size)); + } + + *len = input_size; + return SCM_CHAR (maybe_char); } -/* 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. */ -static SCM_C_INLINE int -get_codepoint (SCM port, scm_t_wchar *codepoint, - char buf[SCM_MBCHAR_BUF_SIZE], size_t *len) +/* 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 scm_t_wchar +peek_codepoint (SCM port, SCM *buf, size_t *cur, size_t *len) { - int err; - scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + SCM encoding = SCM_PORT (port)->encoding; - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8) - err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len); - else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) - err = get_latin1_codepoint (port, codepoint, buf, len); + if (scm_is_eq (encoding, sym_UTF_8)) + return peek_utf8_codepoint (port, buf, cur, len); + else if (scm_is_eq (encoding, sym_ISO_8859_1)) + return peek_latin1_codepoint (port, buf, cur, len); else - err = get_iconv_codepoint (port, codepoint, buf, 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 - && (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); - } - update_port_lf (*codepoint, port); - } - else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK) - { - *codepoint = '?'; - err = 0; - update_port_lf (*codepoint, port); - } - - return err; + return peek_iconv_codepoint (port, buf, cur, len); } /* 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; - size_t len; + size_t len = 0; + size_t cur; + SCM buf; scm_t_wchar codepoint; - char buf[SCM_MBCHAR_BUF_SIZE]; - err = get_codepoint (port, &codepoint, buf, &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); + 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); return codepoint; } #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" @@ -1992,7 +2008,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); @@ -2006,138 +2022,71 @@ 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) +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); - size_t old_len, new_len; - - scm_i_clear_pending_eof (port); - - if (pt->read_buf != pt->putback_buf) - /* switch to the put-back buffer. */ - { - 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"); - } - - 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; - - /* 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; - } - - 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); - - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush (port); + scm_t_port *pt = SCM_PORT (port); + SCM read_buf = pt->read_buf; + size_t cur; if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + scm_flush (port); + + 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, &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, cur); + scm_port_buffer_reset_end (read_buf); + scm_port_buffer_putback (read_buf, to_shift, buffered, size); + } + else + { + /* Bah, have to expand the read_buf for the putback. */ + while (size < len + buffered) + size *= 2; + read_buf = scm_expand_port_read_buffer_x (port, + scm_from_size_t (size), + SCM_BOOL_T); + } + + cur = size - buffered; + } + + scm_port_buffer_putback (read_buf, buf, len, cur); } #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; - 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 -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); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (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) { @@ -2149,47 +2098,50 @@ scm_ungetc_unlocked (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, - (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, "conversion to port encoding failed", - SCM_BOOL_F, SCM_MAKE_CHAR (c)); + port, 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); - 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 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 @@ -2198,18 +2150,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, @@ -2235,43 +2176,17 @@ 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 result; + SCM buf; scm_t_wchar c; - char bytes[SCM_MBCHAR_BUF_SIZE]; - long column, line; - size_t len = 0; + size_t cur, len = 0; if (SCM_UNBNDP (port)) port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); - column = SCM_COL (port); - line = SCM_LINUM (port); + c = peek_codepoint (port, &buf, &cur, &len); - err = get_codepoint (port, &c, bytes, &len); - - scm_i_unget_bytes_unlocked ((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; + return c == EOF ? SCM_EOF_VAL : SCM_MAKE_CHAR (c); } #undef FUNC_NAME @@ -2293,7 +2208,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 @@ -2315,7 +2230,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; } @@ -2326,139 +2241,112 @@ 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) +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 one\n" + "of the following symbols:\n" + "@table @code\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 { - 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; -} + long csize; + scm_t_port *pt; + scm_t_port_type *ptob; + scm_t_bits tag_word; + size_t read_buf_size, write_buf_size, cur, avail; + SCM saved_read_buf; -/* 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); + port = SCM_COERCE_OUTPORT (port); - assert (pt->read_pos == pt->read_end); + SCM_VALIDATE_OPENPORT (1, port); + pt = SCM_PORT (port); + ptob = SCM_PORT_TYPE (port); + tag_word = SCM_CELL_WORD_0 (port) & ~(SCM_BUF0 | SCM_BUFLINE); - if (pti->pending_eof) + if (scm_is_eq (mode, sym_none)) { - pti->pending_eof = 0; - return EOF; + 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 (!SCM_UNBNDP (size) && csize < 0) + scm_out_of_range (FUNC_NAME, size); + + if (csize >= 0) + read_buf_size = write_buf_size = csize; + 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 (); } - 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); + /* 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 (port); + + saved_read_buf = pt->read_buf; + + SCM_SET_CELL_WORD_0 (port, tag_word); + 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); + + 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)); + + return SCM_UNSPECIFIED; } +#undef FUNC_NAME -int -scm_fill_input (SCM port) -{ - scm_i_pthread_mutex_t *lock; - int ret; - - scm_c_lock_port (port, &lock); - ret = scm_fill_input_unlocked (port); - if (lock) - scm_i_pthread_mutex_unlock (lock); - - - 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_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) - { - 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_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) - { - 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); - - 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; + SCM read_buf = SCM_PORT (port)->read_buf; + 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. */ @@ -2479,22 +2367,18 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, "for further input.") #define FUNC_NAME s_scm_drain_input { - SCM result; - char *data; - scm_t_port *pt; - long count; + SCM read_buf, result; + size_t avail, cur; SCM_VALIDATE_OPINPORT (1, port); - pt = SCM_PTAB_ENTRY (port); + read_buf = SCM_PORT (port)->read_buf; + avail = scm_port_buffer_can_take (read_buf, &cur); - count = pt->read_end - pt->read_pos; - if (pt->read_buf == pt->putback_buf) - count += pt->saved_read_end - pt->saved_read_pos; - - if (count) + if (avail) { - result = scm_i_make_string (count, &data, 0); - scm_take_from_input_buffers (port, data, 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; @@ -2503,36 +2387,25 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, } #undef FUNC_NAME -void -scm_end_input_unlocked (SCM port) -{ - long offset; - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - 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; - - SCM_PORT_DESCRIPTOR (port)->end_input (port, offset); -} - 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 buf; + size_t cur, avail; + scm_t_off offset; + + buf = SCM_PORT (port)->read_buf; + avail = scm_port_buffer_can_take (buf, &cur); + scm_port_buffer_did_take (buf, cur, avail); + offset = - (scm_t_off) avail; + + if (offset != 0) + { + 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, @@ -2552,152 +2425,1202 @@ 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 -void -scm_flush_unlocked (SCM port) -{ - SCM_PORT_DESCRIPTOR (port)->flush (port); -} +static void scm_i_write (SCM port, SCM 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 buf = SCM_PORT (port)->write_buf; + size_t cur; + if (scm_port_buffer_can_take (buf, &cur)) + scm_i_write (port, buf); } -int -scm_fill_input_unlocked (SCM port) +/* 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) { - return scm_i_fill_input_unlocked (port); + SCM read_buf; + const scm_t_uint8 *buf; + size_t cur, avail; + + 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, &cur, &avail); + buf = scm_port_buffer_take_pointer (read_buf, cur); + + if (avail < bom_len) + return 0; + + if (memcmp (buf, bom, bom_len) != 0) + return 0; + + scm_port_buffer_did_take (read_buf, cur, 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 *pt = SCM_PORT (port); + + if (!pt->at_stream_start_for_bom_read) + return 0; + + /* Maybe slurp off a byte-order marker. */ + 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; + + 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))) + { + scm_specialize_port_encoding_x (port, sym_UTF_16LE); + return 2; + } + if (maybe_consume_bom (port, scm_utf16be_bom, sizeof (scm_utf16be_bom))) + { + scm_specialize_port_encoding_x (port, sym_UTF_16BE); + return 2; + } + /* Big-endian by default. */ + scm_specialize_port_encoding_x (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. */ + scm_specialize_port_encoding_x (port, sym_UTF_32LE); + return 4; + } + if (maybe_consume_bom (port, scm_utf32be_bom, sizeof (scm_utf32be_bom))) + { + scm_specialize_port_encoding_x (port, sym_UTF_32BE); + return 4; + } + /* Big-endian by default. */ + scm_specialize_port_encoding_x (port, sym_UTF_32BE); + return 0; + } + + 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 *pt; + + SCM_VALIDATE_PORT (1, port); + + pt = SCM_PORT (port); + if (!pt->at_stream_start_for_bom_read) + return SCM_BOOL_F; + + /* Maybe slurp off a byte-order marker. */ + pt->at_stream_start_for_bom_read = 0; + if (pt->rw_random) + pt->at_stream_start_for_bom_write = 0; + + return SCM_BOOL_T; +} +#undef FUNC_NAME + +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, 1, 0, + (SCM port, SCM buf), + "") +#define FUNC_NAME s_scm_port_clear_stream_start_for_bom_write +{ + scm_t_port *pt; + + SCM_VALIDATE_PORT (1, port); + + pt = SCM_PORT (port); + if (!pt->at_stream_start_for_bom_write) + return SCM_INUM0; + + 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; + + /* Write a BOM if appropriate. */ + if (scm_is_eq (pt->encoding, sym_UTF_16)) + { + SCM precise_encoding; + 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), end, avail); + else + ret = scm_port_buffer_put (buf, 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 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), end, avail); + else + ret = scm_port_buffer_put (buf, scm_utf32be_bom, + sizeof (scm_utf32be_bom), end, avail); + + return scm_from_size_t (ret); + } + + return SCM_INUM0; +} +#undef FUNC_NAME + +SCM +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 cur, buffered; + + 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, &cur); + + if (buffered >= minimum_size + || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) + { + *cur_out = cur; + *avail_out = buffered; + return read_buf; + } + + if (pt->rw_random) + 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 + the end of the buffer. */ + if (minimum_size > scm_port_buffer_size (read_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 + { + 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, 0), to_shift, buffered); + scm_port_buffer_did_put (read_buf, 0, buffered); + } + + 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); + scm_port_buffer_did_put (read_buf, buffered, count); + buffered += 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; +} + +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_PORT (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_PORT (port)->read_buffering); +} +#undef FUNC_NAME + +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, cur, avail; + SCM new_buf; + + SCM_VALIDATE_OPINPORT (1, port); + pt = SCM_PORT (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 = 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, 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, cur), + avail, 0, c_size); + } + pt->read_buf = new_buf; + + return new_buf; +} +#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_TYPE (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_TYPE (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.") +#define FUNC_NAME s_scm_port_read_buffer +{ + SCM_VALIDATE_OPPORT (1, port); + return SCM_PORT (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.") +#define FUNC_NAME s_scm_port_write_buffer +{ + SCM_VALIDATE_OPPORT (1, port); + return SCM_PORT (port)->write_buf; +} +#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 + +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 + /* Output. */ +static void +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)); + + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + + do + { + size_t ret = ptob->c_write (port, src, start + written, count - written); + + if (ret == (size_t) -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; + } + while (written < count); + + scm_dynwind_end (); + + assert (written == count); +} + +static void +scm_i_write (SCM port, SCM buf) +{ + size_t start, count; + + 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 + 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. */ + + 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); +} + +/* 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! */ +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 write_buf; + + SCM_VALIDATE_OPOUTPORT (1, port); + + pt = SCM_PORT (port); + write_buf = pt->write_buf; + + if (pt->rw_random) + scm_end_input (port); + + 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, &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, &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, + end, count); + } + + 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, &tmp)) + scm_i_write (port, write_buf); + + scm_i_write_bytes (port, src, start, 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 (SCM port, const void *ptr, size_t size) +#define FUNC_NAME "scm_c_write" +{ + scm_t_port *pt; + SCM write_buf; + size_t end, avail, written = 0; + int using_aux_buffer = 0; + const scm_t_uint8 *src = ptr; + + SCM_VALIDATE_OPOUTPORT (1, port); + + pt = SCM_PORT (port); + + 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); + } + + 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, + end, avail); + written += did_put; + src += did_put; + 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 + +/* 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; +} + +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 +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; +} + +static size_t +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); + 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; + + 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) + { + /* Success. */ + scm_port_buffer_did_put (buf, end, can_put - output_left); + return 1; + } + + 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); + 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); + } + else if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) + { + 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); + } + + if (res != (size_t) -1) + { + scm_port_buffer_did_put (buf, end, 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 size_t +encode_latin1_chars_to_latin1_buf (SCM port, SCM buf, + const scm_t_uint8 *chars, size_t 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) +{ + 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, 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) +{ + 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_latin1_chars (SCM port, SCM buf, const scm_t_uint8 *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_latin1_chars_to_latin1_buf (port, buf, chars, count); + else if (scm_is_eq (pt->encoding, sym_UTF_8)) + ret = encode_latin1_chars_to_utf8_buf (port, buf, chars, count); + else + 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; + 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); + 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++) + { + 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, end, written); + return read; +} + +static size_t +encode_utf32_chars_to_utf8_buf (SCM port, SCM buf, const scm_t_uint32 *chars, + size_t count) +{ + 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, end, 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 + +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) +{ + 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) && + !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 *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_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) && + !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); + } +} + +/* 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) +{ + 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_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; + + 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); + 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_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_c_put_char (port, (scm_t_uint8) c); } 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_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" -{ - scm_t_port *pt; - scm_t_ptob_descriptor *ptob; - - SCM_VALIDATE_OPOUTPORT (1, port); - - pt = SCM_PTAB_ENTRY (port); - ptob = SCM_PORT_DESCRIPTOR (port); - - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); - - ptob->write (port, ptr, size); - - if (pt->rw_random) - pt->rw_active = SCM_PORT_WRITE; -} -#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); - + 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 - * column. */ -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); - - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); - - ptob->write (port, ptr, size); - - for (; size; ptr++, size--) - update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port); - - if (pt->rw_random) - pt->rw_active = SCM_PORT_WRITE; -} - + * column, flushing line-buffered ports when appropriate. */ 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); - + scm_c_put_latin1_chars (port, (const scm_t_uint8 *) ptr, size); } /* 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; + scm_c_put_string (port, str, start, end - start); } @@ -2723,7 +3646,8 @@ 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; + size_t tmp; if (SCM_UNBNDP (port)) port = scm_current_input_port (); @@ -2731,21 +3655,25 @@ 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 = SCM_PORT (port)->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 (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; 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)); + { + 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; } @@ -2789,20 +3717,41 @@ 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_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port); + scm_t_port *pt = SCM_PORT (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; - if (!ptob->seek) + 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. */ + 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, &tmp); + rv += scm_port_buffer_can_take (pt->write_buf, &tmp); + 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)); - else - rv = ptob->seek (fd_port, off, how); + + 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. */ - 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); @@ -2892,19 +3841,22 @@ 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); + scm_t_port_type *ptob = SCM_PORT_TYPE (object); if (!ptob->truncate) 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) - ptob->flush (object); + if (SCM_INPUT_PORT_P (object) + && SCM_PORT (object)->rw_random) + 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 @@ -2935,7 +3887,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 @@ -2947,7 +3899,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_PTAB_ENTRY (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 @@ -2966,7 +3919,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 @@ -2978,7 +3931,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_PTAB_ENTRY (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 @@ -3019,7 +3973,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) @@ -3034,15 +3988,15 @@ 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_unlocked ("#<", port); + scm_puts ("#<", port); scm_print_port_mode (exp, port); - scm_puts_unlocked (type, port); - scm_putc_unlocked (' ', port); - scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port); - scm_putc_unlocked ('>', port); + scm_puts (type, port); + scm_putc (' ', port); + scm_uintprint ((scm_t_bits) SCM_PORT (exp), 16, port); + scm_putc ('>', port); return 1; } @@ -3107,7 +4061,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, @@ -3126,30 +4080,24 @@ 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 int fill_input_void_port (SCM port SCM_UNUSED) +static size_t +void_port_read (SCM port, SCM dst, size_t start, size_t count) { - return EOF; + return 0; } -static void -write_void_port (SCM port SCM_UNUSED, - const void *data SCM_UNUSED, - size_t size SCM_UNUSED) +static size_t +void_port_write (SCM port, SCM src, size_t start, size_t count) { + return count; } 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_void_port_type, mode_bits, 0); } SCM @@ -3175,16 +4123,51 @@ 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" + + 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)); - scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, - write_void_port); + 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); + scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid); +} + +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"); + + 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); + trampoline_to_c_write_subr = + scm_c_make_gsubr ("port-write", 4, 0, 0, + (scm_t_subr) trampoline_to_c_write); + + 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); cur_inport_fluid = scm_make_fluid (); cur_outport_fluid = scm_make_fluid (); @@ -3192,25 +4175,42 @@ scm_init_ports () cur_warnport_fluid = scm_make_fluid (); cur_loadport_fluid = scm_make_fluid (); - scm_i_port_weak_set = scm_c_make_weak_set (31); + 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 ()); -#include "libguile/ports.x" + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ice_9_ports", + (scm_t_extension_init_func) scm_init_ice_9_ports, + NULL); - /* 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; + /* The following bindings are used early in boot-9.scm. */ - SCM_VARIABLE_SET (default_conversion_strategy_var, - scm_make_fluid_with_default (sym_substitute)); - scm_conversion_strategy_init = 1; + /* Used by `include'. */ + 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); - /* 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); - scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid); + /* 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); } /* diff --git a/libguile/ports.h b/libguile/ports.h index f2ab850dd..d131db5be 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" @@ -36,113 +37,29 @@ #include "libguile/struct.h" #include "libguile/threads.h" #include "libguile/strings.h" +#include "libguile/vectors.h" -#define SCM_INITIAL_PUTBACK_BUF_SIZE 4 - -/* 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; - -/* 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. */ - - /* 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; - - SCM file_name; /* debugging support. */ - long line_number; /* debugging support. */ - int column_number; /* debugging support. */ - - /* 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. */ - - /* 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. */ - - 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. */ - - /* 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; - - /* 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 */ - char *encoding; - scm_t_string_failed_conversion_handler ilseq_handler; -} scm_t_port; - - 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)) -/* 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<<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)) @@ -154,99 +71,56 @@ 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 -#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_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) +typedef struct scm_t_port_type scm_t_port_type; +typedef struct scm_t_port scm_t_port; -#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) +#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 enum scm_t_port_type_flags { - SCM_PORT_TYPE_HAS_FLUSH = 1 << 0 -} scm_t_port_type_flags; - -/* port-type description. */ -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); - int (*close) (SCM port); - - void (*write) (SCM port, const void *data, size_t size); - void (*flush) (SCM port); - - 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; - -#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 (char *name, - int (*fill_input) (SCM port), - 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, +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_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, 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_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_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_setvbuf (scm_t_bits tc, - void (*setvbuf) (SCM, long, long)); +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_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. */ SCM_API SCM scm_current_input_port (void); @@ -269,15 +143,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, - 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 (scm_t_bits tag, unsigned long mode_bits, +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_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); @@ -293,70 +165,74 @@ 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_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); -/* 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_INTERNAL SCM scm_port_maybe_consume_initial_byte_order_mark (SCM, SCM, SCM); 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); 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. */ 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); -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); /* Manipulating the buffers. */ -SCM_API void scm_port_non_buffer (scm_t_port *pt); -SCM_API int scm_fill_input (SCM port); -SCM_API int scm_fill_input_unlocked (SCM port); +SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM 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); -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_random_access_p (SCM port); +SCM_INTERNAL SCM scm_port_read_buffering (SCM port); +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); +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_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); -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_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 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); +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_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); @@ -392,75 +268,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; -} - -SCM_INLINE_IMPLEMENTATION int -scm_get_byte_or_eof_unlocked (SCM port) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - 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); -} - -/* 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_t_port *pt = SCM_PTAB_ENTRY (port); - - 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); -} - -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) -{ - 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/posix-w32.c b/libguile/posix-w32.c new file mode 100644 index 000000000..1f00ec168 --- /dev/null +++ b/libguile/posix-w32.c @@ -0,0 +1,1226 @@ +/* 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 + * 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" + +# define WIN32_LEAN_AND_MEAN +#include +#include +#include +#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. + */ +int +uname (struct utsname *uts) +{ + enum { WinNT, Win95, Win98, WinUnknown }; + OSVERSIONINFO osver; + SYSTEM_INFO sysinfo; + DWORD sLength; + DWORD os = WinUnknown; + + memset (uts, 0, sizeof (*uts)); + + osver.dwOSVersionInfoSize = sizeof (osver); + GetVersionEx (&osver); + GetSystemInfo (&sysinfo); + + switch (osver.dwPlatformId) + { + case VER_PLATFORM_WIN32_NT: /* NT, Windows 2000 or Windows XP */ + if (osver.dwMajorVersion == 4) + strcpy (uts->sysname, "Windows NT4x"); /* NT4x */ + else if (osver.dwMajorVersion <= 3) + strcpy (uts->sysname, "Windows NT3x"); /* NT3x */ + else if (osver.dwMajorVersion == 5 && osver.dwMinorVersion < 1) + strcpy (uts->sysname, "Windows 2000"); /* 2k */ + 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) || + ((osver.dwMajorVersion == 4) && (osver.dwMinorVersion > 0))) + { + if (osver.dwMinorVersion >= 90) + strcpy (uts->sysname, "Windows ME"); /* ME */ + else + strcpy (uts->sysname, "Windows 98"); /* 98 */ + os = Win98; + } + else + { + strcpy (uts->sysname, "Windows 95"); /* 95 */ + os = Win95; + } + break; + + case VER_PLATFORM_WIN32s: /* Windows 3.x */ + strcpy (uts->sysname, "Windows"); + break; + } + + sprintf (uts->version, "%ld.%02ld", + osver.dwMajorVersion, osver.dwMinorVersion); + + if (osver.szCSDVersion[0] != '\0' && + (strlen (osver.szCSDVersion) + strlen (uts->version) + 1) < + sizeof (uts->version)) + { + strcat (uts->version, " "); + strcat (uts->version, osver.szCSDVersion); + } + + sprintf (uts->release, "build %ld", osver.dwBuildNumber & 0xFFFF); + + switch (sysinfo.wProcessorArchitecture) + { + case PROCESSOR_ARCHITECTURE_PPC: + strcpy (uts->machine, "ppc"); + break; + case PROCESSOR_ARCHITECTURE_ALPHA: + strcpy (uts->machine, "alpha"); + break; + 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 + */ + switch (os) + { + case Win95: + case Win98: + switch (sysinfo.dwProcessorType) + { + case PROCESSOR_INTEL_386: + case PROCESSOR_INTEL_486: + case PROCESSOR_INTEL_PENTIUM: + sprintf (uts->machine, "i%ld", sysinfo.dwProcessorType); + break; + default: + strcpy (uts->machine, "i386"); + break; + } + break; + case WinNT: + sprintf (uts->machine, "i%d86", sysinfo.wProcessorLevel); + break; + 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; +} + +/* 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 + 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. */ +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) +{ + 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 + { + 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; + + /* 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, + infd, outfd, errfd); + } + } + + errno = errno_save; + return pid; +} + + +/* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't. */ +int +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 (ph, &st)) + { + errno = ECHILD; + return -1; + } + if (st == STILL_ACTIVE) + return 0; + if (status) + *status = st; + CloseHandle (ph); + } + else + _cwait (status, (intptr_t)ph, 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; +} + + +/* 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; + 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; + return -1; + } + 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. */ + 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; +} + +/* Emulation of getpriority and setpriority. */ +#define NZERO 8 + +int +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) + { + errno = ENOSYS; + return -1; + } + + if (who == 0) + hp = GetCurrentProcess (); + else + { + 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) + { + 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; + int child_proc = 0, retval = -1; + + if (which != PRIO_PROCESS) + { + errno = ENOSYS; + return -1; + } + + if (who == 0) + hp = GetCurrentProcess (); + else + { + 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) + { + 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)) + retval = 0; + } + + err = GetLastError (); + + switch (err) + { + case ERROR_INVALID_PARAMETER: + errno = ESRCH; + break; + default: + errno = EPERM; + break; + } + /* The pseudo-handle returned by GetCurrentProcess doesn't + need to be closed. */ + if (hp && who > 0 && !child_proc) + CloseHandle (hp); + + return retval; +} + +/* Emulation of sched_getaffinity and sched_setaffinity. */ +int +sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask) +{ + HANDLE hp; + DWORD err; + int child_proc = 0; + + if (mask == NULL) + { + errno = EFAULT; + return -1; + } + + if (pid == 0) + hp = GetCurrentProcess (); + else + { + 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); + + /* The pseudo-handle returned by GetCurrentProcess doesn't + need to be closed. */ + if (pid > 0 && !child_proc) + 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; + int child_proc = 0; + + if (mask == NULL) + { + errno = EFAULT; + return -1; + } + + if (pid == 0) + hp = GetCurrentProcess (); + else + { + 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); + + /* The pseudo-handle returned by GetCurrentProcess doesn't + need to be closed. */ + if (pid > 0 && !child_proc) + 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 new file mode 100644 index 000000000..f11a25e49 --- /dev/null +++ b/libguile/posix-w32.h @@ -0,0 +1,98 @@ +/* classes: h_files */ + +#ifndef SCM_POSIX_W32_H +#define SCM_POSIX_W32_H + +/* Copyright (C) 2001, 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 + */ + +#include + +#define _UTSNAME_LENGTH 65 +#define _UTSNAME_NODENAME_LENGTH _UTSNAME_LENGTH +#define _UTSNAME_DOMAIN_LENGTH _UTSNAME_LENGTH + +/* Structure describing the system and machine. */ +struct utsname +{ + /* Name of the implementation of the operating system. */ + char sysname[_UTSNAME_LENGTH]; + + /* Name of this node on the network. */ + char nodename[_UTSNAME_NODENAME_LENGTH]; + + /* Current release level of this implementation. */ + char release[_UTSNAME_LENGTH]; + + /* Current version level of this release. */ + char version[_UTSNAME_LENGTH]; + + /* Name of the hardware type the system is running on. */ + char machine[_UTSNAME_LENGTH]; + + /* Name of the domain of this node on the network. */ + char domainname[_UTSNAME_DOMAIN_LENGTH]; +}; + +#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 494df1e0c..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 @@ -81,6 +81,10 @@ #include "libguile/threads.h" +#ifdef __MINGW32__ +# include "posix-w32.h" +#endif + #if HAVE_SYS_WAIT_H # include #endif @@ -238,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 @@ -626,6 +632,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 +660,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, @@ -735,7 +724,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" @@ -754,7 +743,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" @@ -770,7 +761,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" @@ -786,7 +779,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, @@ -800,8 +793,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 +802,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 +813,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 +831,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 +849,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 +864,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 +879,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 +903,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 +928,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 +944,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), @@ -1247,10 +1242,98 @@ 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); + } + + /* Use exit status 127, like shells in this case, as per POSIX + . */ + _exit (127); + + /* 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" @@ -1263,7 +1346,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)); @@ -1312,15 +1395,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) { @@ -1340,91 +1416,102 @@ 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_i_fdes_to_port (c2p[0], scm_mode_bits ("r0"), + sym_read_pipe, + SCM_FPORT_OPTION_NOT_SEEKABLE); + } 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_i_fdes_to_port (p2c[1], scm_mode_bits ("w0"), + sym_write_pipe, + SCM_FPORT_OPTION_NOT_SEEKABLE); } - 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 */ -#ifdef __MINGW32__ -# include "win32-uname.h" +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_uintptr_t ((scm_t_uintptr) SIG_IGN), + SCM_UNDEFINED); +#ifdef SIGQUIT + scm_dynwind_sigaction (SIGQUIT, + scm_from_uintptr_t ((scm_t_uintptr) SIG_IGN), + SCM_UNDEFINED); #endif -#if defined (HAVE_UNAME) || defined (__MINGW32__) + 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 SCM_DEFINE (scm_uname, "uname", 0, 0, 0, (), "Return an object with some information about the computer\n" @@ -1973,7 +2060,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) { @@ -1998,10 +2084,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; @@ -2015,19 +2098,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; @@ -2056,7 +2134,6 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME - #endif /* HAVE_SCHED_SETAFFINITY */ @@ -2236,13 +2313,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 () @@ -2341,11 +2418,14 @@ scm_init_posix () #ifdef HAVE_FORK 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, NULL); -#endif /* HAVE_FORK */ +#endif /* HAVE_START_CHILD */ } /* 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/print.c b/libguile/print.c index d95051183..7667d24bb 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -24,7 +24,6 @@ #endif #include -#include #include #include @@ -45,9 +44,9 @@ #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/syntax.h" #include "libguile/vectors.h" #include "libguile/numbers.h" #include "libguile/vm.h" @@ -61,21 +60,8 @@ /* Character printers. */ -#define PORT_CONVERSION_HANDLER(port) \ - SCM_PTAB_ENTRY (port)->ilseq_handler - -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); @@ -166,7 +152,7 @@ do \ { \ if (pstate->top - pstate->list_offset >= pstate->level) \ { \ - scm_putc_unlocked ('#', port); \ + scm_putc ('#', port); \ return; \ } \ } \ @@ -310,9 +296,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. */ @@ -432,28 +418,27 @@ 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 = SCM_PTAB_ENTRY (port)->ilseq_handler; + 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 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_unlocked ("#{", 2, port); + scm_lfwrite ("#{", 2, port); for (pos = 0; pos < len; pos++) { @@ -462,34 +447,26 @@ 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_unlocked ("\\x", 2, port); + scm_lfwrite ("\\x", 2, port); scm_intprint (c, 16, port); - scm_putc_unlocked (';', port); + scm_putc (';', port); } } - scm_lfwrite_unlocked ("}#", 2, port); + scm_lfwrite ("}#", 2, port); } 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_unlocked ('|', port); + scm_putc ('|', port); for (pos = 0; pos < len; pos++) { @@ -497,13 +474,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 @@ -512,23 +489,18 @@ 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_unlocked ("\\x", 2, port); + scm_lfwrite ("\\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 |...|. */ @@ -558,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_unlocked ("x", port); \ - scm_intprint (i, 16, port); \ - } \ - } \ - while (0) - - void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { @@ -602,7 +559,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) { @@ -610,8 +567,8 @@ 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_putc_unlocked (')', port); + scm_puts (" ...", port); + scm_putc (')', port); } static void @@ -635,20 +592,14 @@ 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 *)))) { - scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port); + scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port); } else { @@ -709,29 +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); - 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 - printed = display_string (scm_i_string_data (exp), - scm_i_is_narrow_string (exp), - len, 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 (exp, printed)); + scm_c_put_string (port, exp, 0, len); } - scm_remember_upto_here_1 (exp); break; case scm_tc7_symbol: @@ -742,11 +679,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) } else { - scm_puts_unlocked ("#', port); + scm_putc ('>', port); } break; case scm_tc7_variable: @@ -777,9 +714,15 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_i_frame_print (exp, port, pstate); break; case scm_tc7_keyword: - scm_puts_unlocked ("#:", port); + 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; case scm_tc7_vm_cont: scm_i_vm_cont_print (exp, port, pstate); break; @@ -796,21 +739,21 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc7_wvect: ENTER_NESTED_DATA (pstate, exp, circref); - scm_puts_unlocked ("#w(", port); + scm_puts ("#w(", port); print_vector_or_weak_vector (exp, scm_c_weak_vector_length (exp), scm_c_weak_vector_ref, port, pstate); EXIT_NESTED_DATA (pstate); break; case scm_tc7_vector: ENTER_NESTED_DATA (pstate, exp, circref); - scm_puts_unlocked ("#(", port); + scm_puts ("#(", port); print_vector_or_weak_vector (exp, SCM_SIMPLE_VECTOR_LENGTH (exp), scm_c_vector_ref, port, pstate); EXIT_NESTED_DATA (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; @@ -886,486 +829,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_unlocked (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_unlocked (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_unlocked (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; - 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 (strcmp(pt->encoding, "UTF-16") == 0 - || strcmp(pt->encoding, "UTF-32") == 0)) - display_character (SCM_UNICODE_BOM, port, iconveh_error); - } - - 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); - - done = iconv (id->output_cd, &input, &input_left, - &output, &output_left); - - output_len = sizeof (encoded_output) - output_left; - - if (SCM_UNLIKELY (done == (size_t) -1)) - { - int errno_save = errno; - - /* Reset the `iconv' state. */ - iconv (id->output_cd, NULL, NULL, NULL, NULL); - - /* Print the OUTPUT_LEN bytes successfully converted. */ - scm_lfwrite_unlocked (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_unlocked (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_internal *pti; - - pti = SCM_PORT_GET_INTERNAL (port); - - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8) - return display_string_as_utf8 (str, narrow_p, len, port); - else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) - 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_unlocked (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_unlocked (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_unlocked (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_unlocked (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_unlocked (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_unlocked (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)); } @@ -1376,14 +922,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. @@ -1392,19 +938,19 @@ scm_uintprint (scm_t_uintmax n, int radix, SCM port) void scm_ipruk (char *hdr, SCM ptr, SCM port) { - scm_puts_unlocked ("#', port); + scm_putc ('>', port); } @@ -1415,7 +961,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; @@ -1445,18 +991,18 @@ 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); } if (!SCM_NULL_OR_NIL_P (exp)) { - scm_puts_unlocked (" . ", port); + scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); } end: - scm_putc_unlocked (tlr, port); + scm_putc (tlr, port); pstate->top = floor + 2; return; @@ -1477,7 +1023,7 @@ fancy_printing: { if (n == 0) { - scm_puts_unlocked (" ...", port); + scm_puts (" ...", port); goto skip_tail; } else @@ -1485,14 +1031,14 @@ 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); } } if (!SCM_NULL_OR_NIL_P (exp)) { - scm_puts_unlocked (" . ", port); + scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); } skip_tail: @@ -1503,7 +1049,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; } @@ -1527,11 +1073,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 +1088,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; } @@ -1584,9 +1122,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 @@ -1665,7 +1201,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 @@ -1677,16 +1213,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; } @@ -1710,7 +1243,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/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); 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/programs.c b/libguile/programs.c index 64c861a71..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 @@ -22,6 +22,7 @@ #include #include "_scm.h" +#include "instructions.h" #include "modules.h" #include "programs.h" #include "procprop.h" /* scm_sym_name */ @@ -103,24 +104,24 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) if (SCM_PROGRAM_IS_CONTINUATION (program)) { /* 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 { @@ -144,19 +145,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); @@ -234,25 +237,75 @@ 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_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; + *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 = 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/libguile/promises.c b/libguile/promises.c index dcd0ac383..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" @@ -88,11 +87,11 @@ static int promise_print (SCM exp, SCM port, scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); - scm_puts_unlocked ("#', port); + scm_putc ('>', port); return !0; } 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/r6rs-ports.c b/libguile/r6rs-ports.c index 2c2b657d7..c2f97ffa1 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -38,6 +38,13 @@ + +SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); +SCM_SYMBOL (sym_error, "error"); + + + + /* Unimplemented features. */ @@ -51,7 +58,9 @@ transcoders_not_implemented (void) PACKAGE_NAME); } + + /* End-of-file object. */ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, @@ -59,101 +68,85 @@ 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 + + /* Input ports. */ #ifndef MIN # define MIN(a,b) ((a) < (b) ? (a) : (b)) #endif -/* Bytevector input ports or "bip" for short. */ -static scm_t_bits bytevector_input_port_type = 0; +/* Bytevector input ports. */ +static scm_t_port_type *bytevector_input_port_type = 0; + +struct bytevector_input_port { + SCM bytevector; + size_t pos; +}; static inline SCM -make_bip (SCM bv) +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; + const unsigned long mode_bits = SCM_RDNG; + struct bytevector_input_port *stream; - port = 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; + 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, + sym_ISO_8859_1, sym_error, + (scm_t_bits) stream); } -static int -bip_fill_input (SCM port) +static size_t +bytevector_input_port_read (SCM port, SCM dst, size_t start, size_t count) { - int result; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); + size_t remaining; + 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 0; - return result; + remaining = SCM_BYTEVECTOR_LENGTH (stream->bytevector) - stream->pos; + if (remaining < count) + count = remaining; + + memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start, + SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, + count); + + stream->pos += count; + + return count; } 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); + 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 @@ -163,10 +156,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_read, NULL); - scm_set_port_seek (bytevector_input_port_type, bip_seek); + scm_set_port_seek (bytevector_input_port_type, bytevector_input_port_seek); } @@ -181,37 +175,46 @@ 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 + + /* Custom binary ports. The following routines are shared by input and output custom binary ports. */ -#define SCM_CBP_GET_POSITION_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1) -#define SCM_CBP_SET_POSITION_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2) -#define SCM_CBP_CLOSE_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3) +struct custom_binary_port { + SCM read; + SCM write; + SCM get_position; + SCM set_position_x; + 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 -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; + 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_CBP_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 " @@ -227,11 +230,8 @@ cbp_seek (SCM port, scm_t_off offset, int whence) case SEEK_SET: { - SCM set_position_proc; - - set_position_proc = SCM_CBP_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"); @@ -252,185 +252,58 @@ cbp_seek (SCM port, scm_t_off offset, int whence) } #undef FUNC_NAME -static int -cbp_close (SCM port) +static void +custom_binary_port_close (SCM port) { - SCM close_proc; + struct custom_binary_port *stream = (void *) SCM_STREAM (port); - close_proc = SCM_CBP_CLOSE_PROC (port); - if (scm_is_true (close_proc)) + if (scm_is_true (stream->close)) /* Invoke the `close' thunk. */ - scm_call_0 (close_proc); - - return 1; + scm_call_0 (stream->close); } + -/* Custom binary input port ("cbip" for short). */ -static scm_t_bits custom_binary_input_port_type = 0; +/* Custom binary input ports. */ -/* Initial size of the buffer embedded in custom binary input ports. */ -#define CBIP_BUFFER_SIZE 8192 - -/* Return the bytevector associated with PORT. */ -#define SCM_CBIP_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) \ - SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv)) - -/* Return the various procedures of PORT. */ -#define SCM_CBIP_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) -{ - SCM bv; - scm_t_port *pt; - - pt = SCM_PTAB_ENTRY (port); - bv = SCM_CBIP_BYTEVECTOR (port); - - 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); - SCM_SET_CBIP_BYTEVECTOR (port, 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 scm_t_port_type *custom_binary_input_port_type = 0; 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; - unsigned c_len; - scm_t_port *c_port; - const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + struct custom_binary_port *stream; + const unsigned long mode_bits = SCM_RDNG; - /* Use a bytevector as the underlying buffer. */ - c_len = CBIP_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 = read_proc; + stream->write = SCM_BOOL_F; + stream->get_position = get_position_proc; + stream->set_position_x = set_position_proc; + stream->close = close_proc; - /* 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); - - 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_UNPACK (method_vector)); - - 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; + sym_ISO_8859_1, sym_error, + (scm_t_bits) stream); } -static int -cbip_fill_input (SCM port) -#define FUNC_NAME "cbip_fill_input" +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" { - int result; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); + struct custom_binary_port *stream = (void *) SCM_STREAM (port); + SCM 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, read_proc, octets; + 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 > count) + scm_out_of_range (FUNC_NAME, octets); - c_requested = c_port->read_buf_size; - read_proc = SCM_CBIP_READ_PROC (port); - - bv = SCM_CBIP_BYTEVECTOR (port); - 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 _IONBF. 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 - 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); - } - } - - octets = scm_call_3 (read_proc, 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; + return c_octets; } #undef FUNC_NAME @@ -456,8 +329,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,15 +341,17 @@ 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_read, 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_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); } + /* Binary input. */ /* We currently don't support specific binary input ports. */ @@ -533,7 +408,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; @@ -541,11 +415,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; @@ -571,7 +444,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; @@ -580,14 +452,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; @@ -601,7 +472,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 " @@ -611,32 +481,22 @@ 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; - size_t size; + SCM buf; + size_t cur, avail; 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 (port, 0, &cur, &avail); + if (avail == 0) { - if (scm_fill_input_unlocked (port) == EOF) - return SCM_EOF_VAL; + scm_port_buffer_set_has_eof_p (buf, SCM_BOOL_F); + 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; - - 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; } @@ -651,14 +511,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 @@ -666,37 +525,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; } @@ -704,6 +553,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, + /* Binary output. */ /* We currently don't support specific binary input ports. */ @@ -720,7 +570,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; } @@ -733,14 +583,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)) { @@ -763,7 +611,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; } @@ -814,163 +662,164 @@ SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2, 2, 0, -/* Bytevector output port ("bop" for short). */ -/* Implementation of "bops". +/* Bytevector output port. */ - 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. +/* Implementation of "bytevector output ports". - XXX: Access to a bop's internal buffer is not thread-safe. */ + 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. -static scm_t_bits bytevector_output_port_type = 0; + XXX: Access to a bytevector output port's internal buffer is not + thread-safe. */ + +static scm_t_port_type *bytevector_output_port_type = 0; 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; + + /* The get-bytevector procedure will flush this port, if it's + open. */ + SCM port; +} 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; + /* Don't clear the port. */ } 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_t_port *c_port; - scm_t_bop_buffer *buf; - const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + SCM port, proc; + scm_t_bytevector_output_port_buffer *buf; + const unsigned long mode_bits = 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, - NULL, /* encoding */ - SCM_FAILED_CONVERSION_ERROR, + sym_ISO_8859_1, sym_error, (scm_t_bits)buf); + buf->port = port; - c_port = SCM_PTAB_ENTRY (port); + SCM_NEWSMOB (proc, bytevector_output_port_procedure, buf); - 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); - - 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) +/* Write octets from WRITE_BUF to the backing store. */ +static size_t +bytevector_output_port_write (SCM port, SCM src, size_t start, size_t count) { - 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); + 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, 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 -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; + scm_t_off target; - buf = SCM_BOP_BUFFER (port); - switch (whence) - { - case SEEK_CUR: - offset += (scm_t_off) buf->pos; - /* Fall through. */ + buf = SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER (port); - 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 -/* 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); + + if (SCM_OPPORTP (buf->port)) + scm_flush (buf->port); 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 +830,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 +850,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,87 +859,58 @@ 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). */ -static scm_t_bits custom_binary_output_port_type; +/* Custom binary output ports. */ -/* Return the various procedures of PORT. */ -#define SCM_CBOP_WRITE_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) +static scm_t_port_type *custom_binary_output_port_type; 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; - const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + struct custom_binary_port *stream; + const unsigned long mode_bits = 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 = 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_UNPACK (method_vector)); - - 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; + sym_ISO_8859_1, sym_error, + (scm_t_bits) stream); } -/* Write SIZE octets from DATA to PORT. */ -static void -cbop_write (SCM port, const void *data, size_t size) -#define FUNC_NAME "cbop_write" +/* Flush octets from BUF to the backing store. */ +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" { - long int c_result; - size_t c_written; - SCM bv, write_proc, result; + struct custom_binary_port *stream = (void *) SCM_STREAM (port); + size_t written; + SCM 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 - pointed to by DATA, and (2) the `write!' procedure could capture the - bytevector it is passed. */ - bv = scm_c_make_bytevector (size); - memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); + result = scm_call_3 (stream->write, src, scm_from_size_t (start), + scm_from_size_t (count)); - write_proc = SCM_CBOP_WRITE_PROC (port); + 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"); - /* 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) - { - result = scm_call_3 (write_proc, bv, - scm_from_size_t (c_written), - scm_from_size_t (size - c_written)); - - c_result = scm_to_long (result); - if (SCM_UNLIKELY (c_result < 0 - || (size_t) c_result > (size - c_written))) - scm_wrong_type_arg_msg (FUNC_NAME, 0, result, - "R6RS custom binary output port `write!' " - "returned a incorrect integer"); - } + return written; } #undef FUNC_NAME @@ -1116,8 +936,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,127 +948,135 @@ 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_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); } + -/* Transcoded ports ("tp" for short). */ -static scm_t_bits transcoded_port_type = 0; -#define TP_INPUT_BUFFER_SIZE 4096 +/* Custom binary input_output ports. */ + +static scm_t_port_type *custom_binary_input_output_port_type; -#define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port)) static inline SCM -make_tp (SCM binary_port, unsigned long mode) +make_custom_binary_input_output_port (SCM read_proc, SCM write_proc, + SCM get_position_proc, + SCM set_position_proc, SCM close_proc) { - 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, + 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 + + +/* 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_port_random_access_p); + scm_set_port_close (custom_binary_input_output_port_type, + custom_binary_port_close); +} + + + + +/* Transcoded ports. */ + +static scm_t_port_type *transcoded_port_type = 0; + +#define SCM_TRANSCODED_PORT_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port)) + +static inline SCM +make_transcoded_port (SCM binary_port, unsigned long mode) +{ + return scm_c_make_port (transcoded_port_type, mode, SCM_UNPACK (binary_port)); +} - 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_pos = c_port->read_end = c_port->read_buf; - c_port->read_buf_size = TP_INPUT_BUFFER_SIZE; - - SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0); - } - - return port; +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_bytes (bport, src, start, count); + return count; +} + +static size_t +transcoded_port_read (SCM port, SCM dst, size_t start, size_t count) +{ + SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); + return scm_c_read_bytes (bport, dst, start, count); } static void -tp_write (SCM port, const void *data, size_t size) +transcoded_port_close (SCM port) { - scm_c_write_unlocked (SCM_TP_BINARY_PORT (port), data, size); -} - -static int -tp_fill_input (SCM port) -{ - size_t count; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); - SCM bport = SCM_TP_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 - block has been read or EOF. */ - - if (c_bport->rw_active == SCM_PORT_WRITE) - scm_force_output (bport); - - 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 -tp_flush (SCM port) -{ - SCM binary_port = SCM_TP_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; - c_port->rw_active = SCM_PORT_NEITHER; - - if (SCM_OPOUTPORTP (binary_port)) - scm_force_output (binary_port); -} - -static int -tp_close (SCM port) -{ - if (SCM_OUTPUT_PORT_P (port)) - tp_flush (port); - return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port))) ? 0 : -1; + 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", tp_fill_input, tp_write); - - scm_set_port_flush (transcoded_port_type, tp_flush); - scm_set_port_close (transcoded_port_type, tp_close); + scm_make_port_type ("r6rs-transcoded-port", transcoded_port_read, + transcoded_port_write); + scm_set_port_close (transcoded_port_type, transcoded_port_close); + scm_set_port_needs_close_on_gc (transcoded_port_type, 1); } SCM_INTERNAL SCM scm_i_make_transcoded_port (SCM); @@ -1269,7 +1097,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 @@ -1308,7 +1136,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; @@ -1330,16 +1158,17 @@ scm_register_r6rs_ports (void) "scm_init_r6rs_ports", (scm_t_extension_init_func) scm_init_r6rs_ports, NULL); + + initialize_bytevector_input_ports (); + initialize_custom_binary_input_ports (); + initialize_bytevector_output_ports (); + initialize_custom_binary_output_ports (); + initialize_custom_binary_input_output_ports (); + initialize_transcoded_ports (); } void scm_init_r6rs_ports (void) { #include "libguile/r6rs-ports.x" - - initialize_bytevector_input_ports (); - initialize_custom_binary_input_ports (); - initialize_bytevector_output_ports (); - initialize_custom_binary_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/libguile/rdelim.c b/libguile/rdelim.c index c8c7d8b43..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" @@ -79,13 +78,13 @@ 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) { 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)); @@ -149,7 +148,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 ecf27ff6e..0946ff379 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 @@ -31,6 +31,7 @@ #include #include #include +#include #include "libguile/_scm.h" #include "libguile/bytevectors.h" @@ -46,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" @@ -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$"); @@ -148,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); @@ -263,13 +264,13 @@ 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; else if (CHAR_IS_DELIMITER (chr)) { - scm_unget_byte_unlocked (chr, port); + scm_unget_byte (chr, port); return 0; } else @@ -335,7 +336,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 +351,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 +363,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"; @@ -381,7 +382,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; @@ -433,14 +434,14 @@ 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) 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 +469,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. */ @@ -557,7 +558,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,13 +588,13 @@ skip_intraline_whitespace (SCM port) do { - c = scm_getc_unlocked (port); + c = scm_getc (port); if (c == EOF) return; } 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 @@ -611,10 +612,10 @@ 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_unlocked (port))) + while (chr != (c = scm_getc (port))) { if (c == EOF) { @@ -634,7 +635,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; @@ -738,10 +739,10 @@ 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_unlocked (chr, port); + scm_ungetc (chr, port); buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &bytes_read); @@ -758,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; } @@ -772,7 +775,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) @@ -795,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; } @@ -832,8 +837,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; } @@ -844,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; @@ -859,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) { @@ -876,12 +883,12 @@ 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 { - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); p = scm_sym_unquote; } break; @@ -906,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) { @@ -923,12 +930,12 @@ 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 { - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); p = sym_unsyntax; } break; @@ -965,9 +972,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; } @@ -987,12 +994,12 @@ 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]) { - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); break; } else @@ -1004,7 +1011,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; } } @@ -1040,7 +1047,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); @@ -1049,7 +1056,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); @@ -1058,16 +1065,16 @@ 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_PORT (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; + scm_set_port_column_x (port, scm_sum (scm_port_column (port), SCM_INUM1)); return SCM_MAKE_CHAR (buffer[0]); } @@ -1075,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); @@ -1181,7 +1190,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 +1200,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,13 +1231,13 @@ 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")) return SCM_BOOL_F; else if (c != EOF) - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); return SCM_BOOL_F; } rank = 1; @@ -1251,7 +1260,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 +1284,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 +1292,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 +1354,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,15 +1385,15 @@ 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); } 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)), @@ -1398,7 +1407,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, @@ -1421,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) @@ -1431,7 +1446,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); @@ -1439,10 +1454,16 @@ 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 */ + { + 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)) @@ -1461,12 +1482,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); } @@ -1477,7 +1498,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 +1506,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, @@ -1518,7 +1539,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; } @@ -1535,9 +1556,10 @@ 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_unlocked (port)) != EOF) + while ((chr = scm_getc (port)) != EOF) { if (saw_brace) { @@ -1564,7 +1586,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; @@ -1599,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); @@ -1628,8 +1647,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); @@ -1653,7 +1672,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 +1762,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) { @@ -1781,8 +1800,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); @@ -1804,8 +1823,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. */ @@ -1868,9 +1887,9 @@ 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); - line = SCM_LINUM (port); - column = SCM_COL (port); + scm_ungetc (c, port); + line = scm_to_long (scm_port_line (port)); + column = scm_to_int (scm_port_column (port)); } expr = read_inner_expression (port, opts); @@ -1881,7 +1900,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 ...) */ @@ -1903,7 +1922,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 +1956,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)); } @@ -2057,27 +2076,23 @@ char * 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; - pt = SCM_PTAB_ENTRY (port); - - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); + pt = SCM_PORT (port); + buf = pt->read_buf; if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + scm_flush (port); - if (pt->read_pos == pt->read_end) + if (scm_port_buffer_can_take (buf, &cur) == 0) { /* 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 (port, 0, &cur, &bytes_read); if (bytes_read > SCM_ENCODING_SEARCH_SIZE) bytes_read = SCM_ENCODING_SEARCH_SIZE; @@ -2085,24 +2100,20 @@ scm_i_scan_for_encoding (SCM port) /* An unbuffered port -- don't scan. */ return NULL; - memcpy (header, pt->read_pos, bytes_read); + 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; - - bytes_read = scm_c_read_unlocked (port, header, SCM_ENCODING_SEARCH_SIZE); + /* 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; @@ -2255,9 +2266,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); @@ -2267,8 +2275,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. */ @@ -2298,6 +2304,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/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; 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/rw.c b/libguile/rw.c index 75c280b4e..70bcd81a0 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -30,12 +30,12 @@ #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" #include "libguile/modules.h" #include "libguile/strports.h" +#include "libguile/ports-internal.h" #include #ifdef HAVE_IO_H @@ -231,22 +231,22 @@ 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 write_buf; + size_t end; 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_PORT (port)->write_buf; + + /* Filling the last character in the buffer would require a + flush. */ + if (write_len < scm_port_buffer_can_put (write_buf, &end)) { - memcpy (pt->write_pos, src, write_len); - pt->write_pos += write_len; + scm_c_write (port, src, write_len); return scm_from_long (write_len); } - if (pt->write_pos > pt->write_buf) - scm_flush_unlocked (port); + + scm_flush (port); fdes = SCM_FPORT_FDES (port); } { diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index a23f151a2..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 @@ -45,7 +45,6 @@ #include "libguile/async.h" #include "libguile/eval.h" -#include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/threads.h" @@ -86,6 +85,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; @@ -109,8 +110,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 @@ -226,9 +229,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 @@ -325,15 +327,14 @@ 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 (); - SCM_CRITICAL_SECTION_START; + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (&signal_handler_lock); + scm_dynwind_block_asyncs (); + old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig); if (SCM_UNBNDP (handler)) query_only = 1; @@ -352,7 +353,6 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, } else { - SCM_CRITICAL_SECTION_END; SCM_OUT_OF_RANGE (2, handler); } } @@ -439,7 +439,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) @@ -458,7 +460,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 } @@ -550,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; @@ -587,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; @@ -597,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), @@ -722,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/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); diff --git a/libguile/smob.c b/libguile/smob.c index eecefd3dc..43ea613de 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -105,14 +105,14 @@ int 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_puts ("#<", port); + scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", 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; } @@ -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/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/socket.c b/libguile/socket.c index 2a9be5471..71c17e892 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 @@ -40,6 +40,7 @@ #include #endif #include +#include #include #include @@ -366,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), @@ -390,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 @@ -412,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 @@ -508,19 +515,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 +644,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 @@ -859,7 +840,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; @@ -884,10 +866,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 @@ -1259,24 +1243,24 @@ 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), - "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" +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" + "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 +#define FUNC_NAME s_scm_accept4 { int fd; int newfd; + int c_flags; SCM address; SCM newsock; socklen_t addr_size = MAX_ADDR_SIZE; @@ -1284,18 +1268,30 @@ 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 = accept (fd, (struct sockaddr *) &addr, &addr_size)); + SCM_SYSCALL (newfd = accept4 (fd, (struct sockaddr *) &addr, &addr_size, + c_flags)); if (newfd == -1) - SCM_SYSERROR; - newsock = SCM_SOCK_FD_TO_PORT (newfd); - address = _scm_from_sockaddr (&addr, addr_size, - FUNC_NAME); + { + if (errno == EAGAIN || errno == EWOULDBLOCK) + return SCM_BOOL_F; + SCM_SYSERROR; + } + newsock = scm_socket_fd_to_port (newfd); + 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" @@ -1657,6 +1653,14 @@ scm_init_socket () scm_c_define ("SOCK_RDM", scm_from_int (SOCK_RDM)); #endif + /* 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. SOL_IP, SOL_TCP and SOL_UDP are defined on gnu/linux, but not on for @@ -1739,6 +1743,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)); 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/libguile/sort.c b/libguile/sort.c index 9373fb892..81ef3ff27 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 @@ -267,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 */ @@ -359,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" @@ -375,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) @@ -404,7 +452,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); } @@ -487,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)) @@ -498,10 +554,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, @@ -549,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 dbebf779f..14e56bd1c 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" @@ -104,11 +103,11 @@ static int srcprops_print (SCM obj, SCM port, scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); - scm_puts_unlocked ("#', port); + scm_putc ('>', port); return 1; } @@ -144,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/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/srfi-14.c b/libguile/srfi-14.c index bf95ce982..af7c1d95b 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -597,27 +597,27 @@ charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) p = SCM_CHARSET_DATA (charset); - 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/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 }; 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/stackchk.c b/libguile/stackchk.c index 6a88c3e08..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" @@ -58,11 +57,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/stacks.c b/libguile/stacks.c index a09c3b9a3..9bd2db8de 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 */ @@ -326,8 +325,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, 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 = c->fp_offset; + frame.sp_offset = c->stack_size; frame.ip = c->ra; } else if (SCM_VM_FRAME_P (obj)) @@ -358,8 +357,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; @@ -413,7 +411,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 */ @@ -461,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/stime.c b/libguile/stime.c index f656d886c..4a7829833 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 @@ -275,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); @@ -331,7 +325,8 @@ filltime (struct tm *bd_time, int zoff, const char *zname) return result; } -static char tzvar[3] = "TZ"; +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 @@ -395,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_i_dynwind_pthread_mutex_lock (&tz_lock); + oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); #ifdef LOCALTIME_CACHE tzset (); @@ -412,7 +409,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 ]; @@ -450,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 @@ -483,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; @@ -521,7 +518,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 @@ -556,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_i_dynwind_pthread_mutex_lock (&tz_lock); oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); #ifdef LOCALTIME_CACHE @@ -572,7 +569,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 ]; @@ -682,7 +679,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 @@ -702,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,11 +717,11 @@ 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); - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&tz_lock); } #endif } @@ -784,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 @@ -834,12 +831,7 @@ scm_init_stime() #ifdef HAVE_POSIX_CPUTIME { - 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; diff --git a/libguile/strings.c b/libguile/strings.c index 90dc83a66..5c49e33d8 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-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 @@ -35,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" @@ -50,41 +50,42 @@ /* {Strings} */ +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_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, \ @@ -94,16 +95,6 @@ #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 @@ -228,8 +219,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. */ @@ -264,15 +253,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); @@ -286,7 +268,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 @@ -356,77 +337,109 @@ 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); + } + + STRINGBUF_SET_MUTABLE (new_buf); + SET_STRING_STRINGBUF (str, new_buf); + } } SCM @@ -436,6 +449,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; @@ -444,6 +459,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); } @@ -489,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. */ @@ -565,60 +589,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; } @@ -658,7 +635,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. */ @@ -765,42 +741,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)); } @@ -879,9 +823,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); } @@ -918,8 +859,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" @@ -981,11 +922,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"), @@ -1012,8 +953,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" @@ -1054,11 +995,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"), @@ -1142,7 +1083,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)) { @@ -1159,7 +1099,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)) { @@ -1171,7 +1110,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); @@ -1190,7 +1128,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 @@ -1208,10 +1151,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; @@ -1610,11 +1551,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 @@ -1673,9 +1621,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); @@ -1756,17 +1704,18 @@ 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_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (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 - && (pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR + else if (scm_is_eq (pt->encoding, sym_UTF_8) + && (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, pt->encoding, pt->ilseq_handler); + return scm_from_stringn (str, len, scm_i_symbol_chars (pt->encoding), + scm_i_string_failed_conversion_handler + (SCM_PORT (port)->conversion_strategy)); } /* Create a new scheme string from the C string STR. The memory of @@ -1937,7 +1886,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 * @@ -2053,6 +2002,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" @@ -2163,16 +2144,17 @@ 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_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (port); - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1 - && pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR) + if (scm_is_eq (pt->encoding, sym_ISO_8859_1) + && scm_is_eq (pt->conversion_strategy, sym_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), + scm_i_string_failed_conversion_handler + (SCM_PORT (port)->conversion_strategy)); } /* Return a malloc(3)-allocated buffer containing the contents of STR encoded diff --git a/libguile/strings.h b/libguile/strings.h index 130c436a6..5b3e7805f 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 @@ -100,10 +101,14 @@ 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); 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); @@ -117,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); @@ -176,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); @@ -188,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/strports.c b/libguile/strports.c index a6a03b4eb..5f78785d1 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" @@ -52,192 +51,103 @@ * */ -/* NOTES: +SCM_SYMBOL (sym_UTF_8, "UTF-8"); - 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. +scm_t_port_type *scm_string_port_type; - ENHANCE-ME - output blocks: +struct string_port { + SCM bytevector; + size_t pos; + size_t len; +}; - 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; - - -static int -st_fill_input (SCM port) +static size_t +string_port_read (SCM port, SCM dst, size_t start, size_t count) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (pt->read_pos >= pt->read_end) - return EOF; - else - return *pt->read_pos; + struct string_port *stream = (void *) SCM_STREAM (port); + + if (stream->pos >= stream->len) + return 0; + + if (count > stream->len - stream->pos) + count = stream->len - stream->pos; + + memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start, + SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, + count); + + stream->pos += count; + return count; } -/* 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) +static size_t +string_port_write (SCM port, SCM src, size_t start, size_t count) { - 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); + struct string_port *stream = (void *) SCM_STREAM (port); - scm_t_off offset = pt->write_pos - pt->write_buf; - - pt->write_buf_size = new_size; - - 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; - } -} - -static void -st_write (SCM port, const void *data, size_t size) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - 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); + memcpy (SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, + SCM_BYTEVECTOR_CONTENTS (src) + start, + count); + stream->pos += count; + if (stream->pos > stream->len) + stream->len = stream->pos; - pt->write_pos = (unsigned char *) (pt->read_pos = pt->read_pos - offset); - pt->rw_active = SCM_PORT_NEITHER; + return count; } 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; - if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR) - /* special case to avoid disturbing the unread-char buffer. */ - { - 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; - } - } + 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 - /* all other cases. */ - { - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter"); - pt->rw_active = SCM_PORT_NEITHER; + if (target >= 0 && target <= stream->len) + stream->pos = target; + else + scm_out_of_range (FUNC_NAME, scm_from_long (offset)); - 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 >= 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; } +#undef FUNC_NAME static void -st_truncate (SCM port, scm_t_off length) +string_port_truncate (SCM port, scm_t_off length) +#define FUNC_NAME "string_port_truncate" { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + struct string_port *stream = (void *) SCM_STREAM (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; + 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. */ #define INITIAL_BUFFER_SIZE 128 @@ -247,10 +157,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); @@ -258,55 +167,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; - pt->rw_random = 1; - - return z; + return + scm_c_make_port_with_encoding (scm_string_port_type, 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 @@ -314,12 +202,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, @@ -334,8 +226,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); @@ -386,8 +277,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 @@ -400,12 +290,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 @@ -427,15 +312,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; } @@ -494,22 +377,22 @@ scm_eval_string (SCM string) return scm_eval_string_in_module (string, SCM_UNDEFINED); } -static scm_t_bits -scm_make_stptob () +static scm_t_port_type * +scm_make_string_port_type () { - scm_t_bits tc = scm_make_port_type ("string", st_fill_input, st_write); + scm_t_port_type *ptob = scm_make_port_type ("string", + string_port_read, + string_port_write); + scm_set_port_seek (ptob, string_port_seek); + scm_set_port_truncate (ptob, string_port_truncate); - scm_set_port_end_input (tc, st_end_input); - scm_set_port_seek (tc, st_seek); - scm_set_port_truncate (tc, st_truncate); - - return tc; + return ptob; } void scm_init_strports () { - scm_tc16_strport = scm_make_stptob (); + 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/struct.c b/libguile/struct.c index 8bfbcf433..51c0f111d 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -936,22 +936,22 @@ 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); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); } 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_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 */ @@ -959,19 +959,19 @@ 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); } } - scm_putc_unlocked ('>', port); + scm_putc ('>', port); } } @@ -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); diff --git a/libguile/symbols.c b/libguile/symbols.c index f93833b9d..ab4b2cdd1 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]) @@ -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/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 a5082f849..3a01a1587 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -389,60 +389,51 @@ 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)) -/* 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 5 -#define scm_tc7_variable 7 - -/* couple */ -#define scm_tc7_vector 13 -#define scm_tc7_wvect 15 - -#define scm_tc7_string 21 -#define scm_tc7_number 23 -#define scm_tc7_stringbuf 39 -#define scm_tc7_bytevector 77 - -#define scm_tc7_pointer 31 -#define scm_tc7_hashtable 29 -#define scm_tc7_fluid 37 -#define scm_tc7_dynamic_state 45 - -#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_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 - -/* There are 256 port subtypes. */ -#define scm_tc7_port 125 - -/* 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_symbol 0x05 +#define scm_tc7_variable 0x07 +#define scm_tc7_vector 0x0d +#define scm_tc7_wvect 0x0f +#define scm_tc7_string 0x15 +#define scm_tc7_number 0x17 +#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_atomic_box 0x37 +#define scm_tc7_syntax 0x3d +#define scm_tc7_unused_3f 0x3f +#define scm_tc7_program 0x45 +#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_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: */ diff --git a/libguile/threads.c b/libguile/threads.c index 3dc0f40c3..9ceb5b88a 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 @@ -51,7 +52,6 @@ #include #include "libguile/validate.h" -#include "libguile/root.h" #include "libguile/eval.h" #include "libguile/async.h" #include "libguile/ports.h" @@ -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); @@ -264,18 +266,18 @@ 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; } /*** 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. */ @@ -287,9 +289,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 @@ -301,33 +300,31 @@ 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)) - 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; } @@ -370,30 +367,12 @@ 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. */ 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; @@ -405,20 +384,14 @@ 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; 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; - 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__ t.register_backing_store_base = base->reg_base; @@ -426,9 +399,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) @@ -437,10 +408,9 @@ guilify_self_1 (struct GC_stack_base *base) currently have type `void'. */ abort (); - scm_i_pthread_mutex_init (&t.admin_mutex, NULL); - t.canceled = 0; t.exited = 0; t.guile_mode = 0; + t.needs_unregister = needs_unregister; /* The switcheroo. */ { @@ -470,7 +440,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; @@ -487,16 +457,14 @@ 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); + 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"); 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(). */ @@ -504,130 +472,22 @@ 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. -*/ - -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 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? */ - - 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 SCM -call_cleanup (void *data) -{ - SCM *proc_p = data; - return scm_call_0 (*proc_p); -} - -/* Perform thread tear-down, in guile mode. - */ -static void * -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; - close (t->sleep_pipe[0]); - close (t->sleep_pipe[1]); - 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; -} - -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. */ + /* 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; - /* If we were canceled, we were unable to clear `t->guile_mode', so do - it here. */ - t->guile_mode = 0; + t->exited = 1; - /* 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; - } + close (t->sleep_pipe[0]); + close (t->sleep_pipe[1]); + t->sleep_pipe[0] = t->sleep_pipe[1] = -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); - - /* 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) @@ -650,16 +510,28 @@ on_thread_exit (void *v) scm_i_pthread_mutex_unlock (&thread_admin_mutex); - scm_i_pthread_setspecific (scm_i_thread_key, 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 (t->vp) - { - scm_i_vm_free_stack (t->vp); - t->vp = NULL; - } +#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 } @@ -677,8 +549,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. @@ -689,7 +560,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); @@ -721,6 +593,8 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent) } else { + int needs_unregister = 0; + /* Guile is already initialized, but this thread enters it for the first time. Only initialize this thread. */ @@ -728,11 +602,12 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent) /* 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_2 (parent); + guilify_self_1 (base, needs_unregister); + guilify_self_2 (dynamic_state); } return 1; } @@ -744,8 +619,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"); @@ -757,7 +631,7 @@ struct with_guile_args { GC_fn_type func; void *data; - SCM parent; + SCM dynamic_state; }; static void * @@ -769,14 +643,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) { @@ -818,22 +692,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 * @@ -858,34 +731,66 @@ scm_without_guile (void *(*func)(void *), void *data) /*** Thread creation */ -typedef struct { - SCM parent; +/* 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 launch_data launch_data; + +struct launch_data { + launch_data *prev; + launch_data *next; + SCM dynamic_state; SCM thunk; - SCM handler; - SCM thread; - scm_i_pthread_mutex_t mutex; - scm_i_pthread_cond_t cond; -} 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) { - 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_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); return 0; } @@ -894,137 +799,48 @@ 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; } -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->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) { - 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 -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, @@ -1036,152 +852,35 @@ 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; -#if !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL - -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 +static SCM join_thread_var; -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 +scm_join_thread (SCM thread) { - 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->canceled)) - 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 || t->canceled) ? 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); + 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, thread, &t->admin_mutex, - timeout_ptr); - 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), @@ -1193,194 +892,196 @@ SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0, #undef FUNC_NAME + + +/* 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 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. */ + 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. */ + 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 + 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. */ + SCM_MUTEX_UNOWNED +}; + +struct scm_mutex { + scm_i_pthread_mutex_t lock; + /* The thread that owns this mutex, or #f if the mutex is unlocked. */ + SCM owner; + /* 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) +#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 -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_unlocked ("#", port); + scm_puts (">", port); return 1; } -static SCM -make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock) +SCM_SYMBOL (allow_external_unlock_sym, "allow-external-unlock"); +SCM_SYMBOL (recursive_sym, "recursive"); + +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 { - fat_mutex *m; - SCM mx; + enum scm_mutex_kind mkind = SCM_MUTEX_STANDARD; + struct scm_mutex *m; scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; - m = scm_gc_malloc (sizeof (fat_mutex), "mutex"); + if (!SCM_UNBNDP (kind)) + { + if (scm_is_eq (kind, allow_external_unlock_sym)) + mkind = SCM_MUTEX_UNOWNED; + else if (scm_is_eq (kind, recursive_sym)) + mkind = SCM_MUTEX_RECURSIVE; + else + SCM_MISC_ERROR ("unsupported mutex kind: ~a", scm_list_1 (kind)); + } + + 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)); m->owner = SCM_BOOL_F; m->level = 0; - - m->recursive = recursive; - m->unchecked_unlock = unchecked_unlock; - m->allow_external_unlock = external_unlock; - - 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_flags (SCM_EOL); -} - -SCM_SYMBOL (unchecked_unlock_sym, "unchecked-unlock"); -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 -{ - int unchecked_unlock = 0, 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)) - external_unlock = 1; - else if (scm_is_eq (flag, recursive_sym)) - recursive = 1; - else - 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 scm_new_smob (scm_tc16_mutex | (mkind << 16), (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. ") #define FUNC_NAME s_scm_make_recursive_mutex { - return make_fat_mutex (1, 0, 0); + return scm_make_mutex_with_kind (recursive_sym); } #undef FUNC_NAME -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) +SCM +scm_lock_mutex (SCM mx) { - fat_mutex *m = SCM_MUTEX_DATA (mutex); - - SCM new_owner = SCM_UNBNDP (owner) ? scm_current_thread() : owner; - SCM err = SCM_BOOL_F; - - struct timeval current_time; + 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); - while (1) + if (scm_is_eq (m->owner, SCM_BOOL_F)) { - if (m->level == 0) - { - 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; - } - 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) - { - m->level++; - *ret = 1; - } - else - { - err = scm_cons (scm_misc_error_key, - scm_from_locale_string ("mutex already locked " - "by thread")); - *ret = 0; - } - break; - } - else - { - if (timeout != 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)) - { - *ret = 0; - break; - } - } - block_self (m->waiting, mutex, &m->lock, timeout); - scm_i_pthread_mutex_unlock (&m->lock); - SCM_TICK; - scm_i_scm_pthread_mutex_lock (&m->lock); - } + m->owner = current_thread->handle; + scm_i_pthread_mutex_unlock (&m->lock); + return SCM_BOOL_T; } - scm_i_pthread_mutex_unlock (&m->lock); - return err; -} + 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); -SCM scm_lock_mutex (SCM mx) -{ - return scm_lock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED); + 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_lock_mutex_timed, "lock-mutex", 1, 2, 0, - (SCM m, SCM timeout, SCM owner), - "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 +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 exception; - int ret = 0; scm_t_timespec cwaittime, *waittime = NULL; + struct scm_mutex *m; + scm_i_thread *t = SCM_I_CURRENT_THREAD; + SCM ret; - SCM_VALIDATE_MUTEX (1, m); + SCM_VALIDATE_MUTEX (1, mutex); + m = SCM_MUTEX_DATA (mutex); if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout)) { @@ -1388,13 +1089,26 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0, waittime = &cwaittime; } - if (!SCM_UNBNDP (owner) && !scm_is_false (owner)) - SCM_VALIDATE_THREAD (3, owner); + /* Specialized lock_mutex implementations according to the mutex + kind. */ + switch (SCM_MUTEX_KIND (mutex)) + { + 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 (); + } - exception = fat_mutex_lock (m, waittime, owner, &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; + scm_remember_upto_here_1 (mutex); + + return ret; } #undef FUNC_NAME @@ -1419,191 +1133,83 @@ 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; + return scm_timed_lock_mutex (mutex, SCM_INUM0); +} - SCM_VALIDATE_MUTEX (1, mutex); +/* 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); - to_timespec (scm_from_int(0), &cwaittime); - waittime = &cwaittime; + 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); + } - 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; + 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 -/*** 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 -remove_mutex_from_thread (SCM mutex, scm_i_thread *t) +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 { - 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) -{ - SCM owner; - fat_mutex *m = SCM_MUTEX_DATA (mutex); - fat_cond *c = NULL; + struct scm_mutex *m; scm_i_thread *t = SCM_I_CURRENT_THREAD; - int err = 0, ret = 0; - scm_i_scm_pthread_mutex_lock (&m->lock); + SCM_VALIDATE_MUTEX (1, mutex); - owner = m->owner; + m = SCM_MUTEX_DATA (mutex); - if (!scm_is_eq (owner, t->handle)) + /* Specialized unlock_mutex implementations according to the mutex + kind. */ + switch (SCM_MUTEX_KIND (mutex)) { - 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; - } - else if (!m->allow_external_unlock) - { - scm_i_pthread_mutex_unlock (&m->lock); - scm_misc_error (NULL, "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 (! (SCM_UNBNDP (cond))) - { - c = SCM_CONDVAR_DATA (cond); - while (1) - { - int brk = 0; + scm_remember_upto_here_1 (mutex); - 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); - } - - 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, owner); - 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); - } - } - else - { - 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); - } - - scm_i_pthread_mutex_unlock (&m->lock); - ret = 1; - } - - return ret; -} - -SCM scm_unlock_mutex (SCM mx) -{ - 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_BOOL_T; } #undef FUNC_NAME @@ -1622,7 +1228,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); @@ -1640,7 +1246,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 @@ -1650,17 +1261,31 @@ 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 + + + +struct scm_cond { + scm_i_pthread_mutex_t lock; + SCM waiting; /* the threads waiting for this condition. */ +}; + +#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, 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); - scm_puts_unlocked ("#", port); + scm_puts (">", port); return 1; } @@ -1669,10 +1294,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 (); @@ -1680,8 +1305,103 @@ 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. + + 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)) + { + m->level++; + scm_i_pthread_mutex_unlock (&m->lock); + } + 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); + } + current_thread->block_asyncs--; + + /* 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) + /* Let caller run scm_async_tick() and loop. */ + return SCM_BOOL_T; + 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 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, " @@ -1693,52 +1413,70 @@ 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; + struct scm_cond *c; + struct scm_mutex *m; + scm_i_thread *t = SCM_I_CURRENT_THREAD; + SCM ret; - 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 fat_mutex_unlock (mx, cv, waitptr, 1) ? SCM_BOOL_T : SCM_BOOL_F; + /* Specialized timed_wait implementations according to the mutex + kind. */ + switch (SCM_MUTEX_KIND (mutex)) + { + 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 (); + } + + scm_remember_upto_here_2 (mutex, cond); + + return ret; } #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 { + struct scm_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 { + struct scm_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 @@ -1802,41 +1540,45 @@ scm_std_select (int nfds, readfds = &my_readfds; } - while (scm_i_setup_sleep (t, SCM_BOOL_F, NULL, 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; - - t->sleep_fd = -1; - scm_i_reset_sleep (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; @@ -1875,14 +1617,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 @@ -1890,14 +1625,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 @@ -2044,21 +1772,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 -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; @@ -2076,8 +1789,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); @@ -2086,44 +1797,55 @@ 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; 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" + + 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")); +} + void 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_set_smob_print (scm_tc16_mutex, fat_mutex_print); + 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); + default_dynamic_state = SCM_BOOL_F; + guilify_self_2 (scm_i_make_initial_dynamic_state ()); 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 scm_init_threads_default_dynamic_state () { - SCM state = scm_make_dynamic_state (scm_current_dynamic_state ()); - scm_i_default_dynamic_state = state; -} - -void -scm_init_thread_procs () -{ -#include "libguile/threads.x" + default_dynamic_state = scm_current_dynamic_state (); } diff --git a/libguile/threads.h b/libguile/threads.h index 6b85baf52..55c566d23 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" @@ -47,30 +46,26 @@ 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; + typedef struct scm_i_thread { struct scm_i_thread *next_thread; SCM handle; scm_i_pthread_t pthread; - SCM cleanup_handler; - SCM join_queue; - - scm_i_pthread_mutex_t admin_mutex; - SCM mutexes; - scm_i_pthread_mutex_t *held_mutex; - SCM result; - int canceled; int exited; /* 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; - 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; @@ -78,19 +73,17 @@ 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; /* 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. @@ -116,10 +109,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) @@ -138,10 +127,8 @@ 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_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); @@ -149,21 +136,18 @@ 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); 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 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); -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); @@ -183,8 +167,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, diff --git a/libguile/throw.c b/libguile/throw.c index bbde5e009..123544e79 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -76,8 +76,9 @@ 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; + const void *prev_cookie; scm_t_ptrdiff saved_stack_depth; if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag)) @@ -95,21 +96,20 @@ 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 (); - saved_stack_depth = vp->sp - vp->stack_base; + prev_cookie = vp->resumable_prompt_cookie; + 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); @@ -121,11 +121,12 @@ 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 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); @@ -199,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; @@ -228,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); } @@ -273,8 +277,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); @@ -282,8 +286,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); @@ -360,11 +365,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; @@ -404,8 +410,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); } @@ -528,7 +534,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); @@ -642,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/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, 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/validate.h b/libguile/validate.h index 516a6f750..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); \ @@ -300,6 +305,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/libguile/values.c b/libguile/values.c index 670e22294..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" @@ -60,9 +59,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 7b3f3356c..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" @@ -36,11 +35,11 @@ void scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#', port); + scm_putc ('>', port); } diff --git a/libguile/vectors.c b/libguile/vectors.c index 5dab5454a..328cf6f5f 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" @@ -43,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) { @@ -59,6 +64,7 @@ const SCM * scm_vector_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"); @@ -76,17 +82,12 @@ SCM * scm_vector_writable_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"); + const SCM *ret = scm_vector_elements (vec, h, lenp, incp); - 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_writable_elements (h); + 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, @@ -141,12 +142,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) { @@ -155,8 +155,6 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, i += 1; } - scm_array_handle_release (&handle); - return res; } #undef FUNC_NAME @@ -215,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 7e752dd14..6c88ebf11 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -107,7 +107,7 @@ { \ SYNC_IP (); \ exp; \ - CACHE_FP (); \ + CACHE_SP (); \ } \ } while (0) #else @@ -127,38 +127,37 @@ #define ABORT_CONTINUATION_HOOK() \ RUN_HOOK0 (abort) -#define VM_HANDLE_INTERRUPTS \ - SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_FP ()) + /* 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 + 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 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. - 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. 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_FP afterwards to restore the possibly-changed FP. */ + CACHE_SP afterwards to restore the possibly-changed stack pointer. */ #define SYNC_IP() vp->ip = (ip) -#define CACHE_FP() fp = (vp->fp) +#define CACHE_SP() sp = vp->sp #define CACHE_REGISTER() \ do { \ ip = vp->ip; \ - fp = vp->fp; \ + CACHE_SP (); \ } while (0) @@ -172,38 +171,36 @@ 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) \ + 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_FP (); \ + vm_expand_stack (vp, sp); \ + CACHE_SP (); \ } \ else \ - vp->sp_max_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_max_since_gc) \ - vp->sp_max_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) \ - (vp->sp + 1 - LOCAL_ADDRESS (slot)) -#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() \ @@ -246,47 +243,29 @@ case opcode: #endif -#define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i)) -#define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i) -#define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, 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_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) + +#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 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)) -#define RETURN_ONE_VALUE(ret) \ - do { \ - SCM val = ret; \ - SCM *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; \ - /* Leave proc. */ \ - SCM_FRAME_LOCAL (old_fp, 1) = val; \ - vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \ - 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); \ - fp[0] = vm_builtin_apply; \ - fp[1] = vm_builtin_values; \ - fp[2] = 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); \ @@ -302,87 +281,116 @@ 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]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ 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); \ - x = LOCAL_REF (a); \ - y = LOCAL_REF (b); \ - if ((ip[1] & 0x1) ? !(exp) : (exp)) \ + UNPACK_24 (op, a); \ + UNPACK_24 (ip[1], b); \ + x = SP_REF (a); \ + y = SP_REF (b); \ + 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); \ - x = LOCAL_REF (a); \ - y = LOCAL_REF (b); \ + UNPACK_24 (op, a); \ + UNPACK_24 (ip[1], 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); \ 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_FP (); \ - if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \ + CACHE_SP (); \ + 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); \ } \ } +#define BR_U64_ARITHMETIC(crel) \ + { \ + 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. */ \ + NEXT (offset); \ + } \ + NEXT (3); \ + } + +#define BR_F64_ARITHMETIC(crel) \ + { \ + scm_t_uint32 a, b; \ + double 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; \ 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_FP (); 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 \ @@ -393,7 +401,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)) \ @@ -405,14 +413,34 @@ 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_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_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) \ + 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) \ + 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_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)) /* Return true (non-zero) if PTR has suitable alignment for TYPE. */ #define ALIGNED_P(ptr, type) \ @@ -426,10 +454,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 SCM *fp 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; @@ -449,8 +477,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, @@ -458,35 +484,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, if (SCM_UNLIKELY (resume)) NEXT (0); - apply: - while (!SCM_PROGRAM_P (LOCAL_REF (0))) - { - SCM proc = LOCAL_REF (0); - - if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) - { - LOCAL_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. */ - RESET_FRAME (n + 1); - while (n--) - LOCAL_SET (n + 1, LOCAL_REF (n)); - - LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc).apply_trampoline); - continue; - } - - SYNC_IP(); - vm_error_wrong_type_apply (proc); - } - - /* Let's go! */ - ip = SCM_PROGRAM_CODE (LOCAL_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 (); @@ -505,7 +506,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. */ @@ -513,19 +514,20 @@ 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; + SYNC_IP (); 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); } - 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; } @@ -543,29 +545,27 @@ 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; - SCM *old_fp; + union scm_vm_stack_element *old_fp; UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); - VM_HANDLE_INTERRUPTS; - PUSH_CONTINUATION_HOOK (); - old_fp = fp; - fp = vp->fp = old_fp + proc; - 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); + 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)))) - goto apply; - - ip = SCM_PROGRAM_CODE (LOCAL_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 (); @@ -582,24 +582,22 @@ 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; - SCM *old_fp; + union scm_vm_stack_element *old_fp; UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); label = ip[2]; - VM_HANDLE_INTERRUPTS; - PUSH_CONTINUATION_HOOK (); - old_fp = fp; - fp = vp->fp = old_fp + proc; - 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); + SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip + 3); RESET_FRAME (nlocals); @@ -616,20 +614,18 @@ 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; UNPACK_24 (op, nlocals); - VM_HANDLE_INTERRUPTS; - RESET_FRAME (nlocals); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0)))) - goto apply; - - ip = SCM_PROGRAM_CODE (LOCAL_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 (); @@ -641,7 +637,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; @@ -649,8 +645,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; @@ -667,26 +661,24 @@ 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; UNPACK_24 (op, from); - VM_HANDLE_INTERRUPTS; - VM_ASSERT (from > 0, abort ()); 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)))) - goto apply; - - ip = SCM_PROGRAM_CODE (LOCAL_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 (); @@ -699,14 +691,14 @@ 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; 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); } @@ -719,7 +711,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); @@ -733,38 +725,37 @@ 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 (U8_U24)) + VM_DEFINE_OP (8, unused_8, NULL, NOP) { - scm_t_uint32 src; - UNPACK_24 (op, src); - RETURN_ONE_VALUE (LOCAL_REF (src)); + vm_error_bad_instruction (op); + abort (); /* never reached */ } - /* 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 (U8_X24)) + VM_DEFINE_OP (9, return_values, "return-values", OP1 (X8_C24)) { - SCM *old_fp; + 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 = 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); /* Clear stack frame. */ - old_fp[-1] = SCM_BOOL_F; - old_fp[-2] = SCM_BOOL_F; + old_fp[0].as_scm = SCM_BOOL_F; + old_fp[1].as_scm = SCM_BOOL_F; POP_CONTINUATION_HOOK (old_fp); @@ -778,72 +769,39 @@ 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 (U8_U24)) + 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 (LOCAL_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 (fp[1]); - break; - case 2: - ret = subr (fp[1], fp[2]); - break; - case 3: - ret = subr (fp[1], fp[2], fp[3]); - break; - case 4: - ret = subr (fp[1], fp[2], fp[3], fp[4]); - break; - case 5: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5]); - break; - case 6: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]); - break; - case 7: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]); - break; - case 8: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]); - break; - case 9: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[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]); - break; - default: - abort (); - } - - CACHE_FP (); + ret = scm_apply_subr (sp, FRAME_LOCALS_COUNT ()); + 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 @@ -854,30 +812,27 @@ 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; + int err = 0; SCM closure, cif, pointer, ret; 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 (); + ret = scm_i_foreign_call (cif, pointer, &err, sp); + CACHE_SP (); - // FIXME: separate args - ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer), - LOCAL_ADDRESS (1)); + ALLOC_FRAME (3); + SP_SET (1, ret); + SP_SET (0, scm_from_int (err)); - CACHE_FP (); - - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - /* multiple values returned to continuation */ - RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); - else - RETURN_ONE_VALUE (ret); + NEXT (1); } /* continuation-call contregs:24 @@ -888,7 +843,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; @@ -896,14 +851,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), - LOCAL_ADDRESS (1)); + sp); scm_i_reinstate_continuation (contregs); /* no NEXT */ @@ -912,27 +867,25 @@ 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, * 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; 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), 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); } @@ -943,18 +896,16 @@ 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; - VM_HANDLE_INTERRUPTS; - nlocals = FRAME_LOCALS_COUNT (); // 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)); @@ -963,20 +914,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)))) - goto apply; - - ip = SCM_PROGRAM_CODE (LOCAL_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 (); @@ -989,20 +940,18 @@ 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; int first; - VM_HANDLE_INTERRUPTS; - SYNC_IP (); dynstack = scm_dynstack_capture_all (&thread->dynstack); - vm_cont = scm_i_vm_capture_stack (vp->stack_base, - SCM_FRAME_DYNAMIC_LINK (fp), - SCM_FRAME_PREVIOUS_SP (fp), - SCM_FRAME_RETURN_ADDRESS (fp), + vm_cont = scm_i_vm_capture_stack (vp->stack_top, + 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 @@ -1014,14 +963,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)))) - goto apply; + SP_SET (1, SP_REF (0)); + SP_SET (0, cont); - ip = SCM_PROGRAM_CODE (LOCAL_REF (0)); + 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 (); @@ -1041,7 +991,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 (); @@ -1051,8 +1001,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, FP_REF (1), nlocals - 2, registers); /* vm_abort should not return */ abort (); @@ -1062,12 +1011,12 @@ 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; UNPACK_12_12 (op, dst, idx); - LOCAL_SET (dst, scm_vm_builtin_ref (idx)); + SP_SET (dst, scm_vm_builtin_ref (idx)); NEXT (1); } @@ -1087,15 +1036,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 (>); } @@ -1107,28 +1056,28 @@ 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); 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 (U8_U24)) + VM_DEFINE_OP (22, assert_nargs_ge, "assert-nargs-ge", OP1 (X8_C24)) { 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 (U8_U24)) + VM_DEFINE_OP (23, assert_nargs_le, "assert-nargs-le", OP1 (X8_C24)) { 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); } @@ -1138,7 +1087,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); @@ -1146,7 +1095,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); } @@ -1157,7 +1106,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); @@ -1165,20 +1114,73 @@ 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; + 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_SLOT (src); + ALLOC_FRAME (FRAME_LOCALS_COUNT () + 1); + SP_SET_SLOT (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; + 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_SLOT (0); + vp->sp = sp = sp + 1; + SP_SET_SLOT (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 = sp = 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); 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); } @@ -1193,7 +1195,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; @@ -1206,9 +1208,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. */ @@ -1231,7 +1233,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; @@ -1259,7 +1261,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; @@ -1267,44 +1269,48 @@ 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); - - VM_ASSERT (has_rest || (nkw % 2) == 0, - vm_error_kwargs_length_not_even (LOCAL_REF (0))); + FP_SET (n++, SCM_UNDEFINED); /* 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)); + 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, - 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; + SYNC_IP (); 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); @@ -1317,7 +1323,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; @@ -1329,20 +1335,22 @@ 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 { + SYNC_IP (); + 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); } @@ -1359,12 +1367,10 @@ 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. */ - if (offset <= 0) - VM_HANDLE_INTERRUPTS; NEXT (offset); } @@ -1373,7 +1379,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)); } @@ -1383,7 +1389,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)); } @@ -1393,7 +1399,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)); } @@ -1403,7 +1409,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)); } @@ -1413,7 +1419,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)); } @@ -1423,7 +1429,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)); } @@ -1433,7 +1439,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)); } @@ -1443,7 +1449,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)); } @@ -1453,7 +1459,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) @@ -1461,20 +1467,26 @@ 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_fp 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, 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 + * + * 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)) + { + 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 @@ -1482,7 +1494,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 (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); } @@ -1492,7 +1504,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); } @@ -1502,7 +1514,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); } @@ -1518,13 +1530,17 @@ 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; UNPACK_12_12 (op, dst, src); - LOCAL_SET (dst, LOCAL_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); } @@ -1533,14 +1549,35 @@ 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)); + /* 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); + } + + /* 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; + + UNPACK_24 (op, dst); + UNPACK_24 (ip[1], src); + FP_SET (dst, FP_REF (src)); NEXT (2); } @@ -1549,12 +1586,13 @@ 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); - LOCAL_SET (dst, scm_inline_cell (thread, scm_tc7_variable, - SCM_UNPACK (LOCAL_REF (src)))); + SYNC_IP (); + SP_SET (dst, scm_inline_cell (thread, scm_tc7_variable, + SCM_UNPACK (SP_REF (src)))); NEXT (1); } @@ -1563,16 +1601,15 @@ 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; UNPACK_12_12 (op, dst, src); - var = LOCAL_REF (src); - VM_ASSERT (SCM_VARIABLEP (var), - vm_error_not_a_variable ("variable-ref", var)); + var = SP_REF (src); + VM_VALIDATE_VARIABLE (var, "variable-ref"); VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (var)); - LOCAL_SET (dst, VARIABLE_REF (var)); + SP_SET (dst, VARIABLE_REF (var)); NEXT (1); } @@ -1580,15 +1617,14 @@ 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; UNPACK_12_12 (op, dst, src); - var = LOCAL_REF (dst); - VM_ASSERT (SCM_VARIABLEP (var), - vm_error_not_a_variable ("variable-set!", var)); - VARIABLE_SET (var, LOCAL_REF (src)); + var = SP_REF (dst); + VM_VALIDATE_VARIABLE (var, "variable-set!"); + VARIABLE_SET (var, SP_REF (src)); NEXT (1); } @@ -1599,7 +1635,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; @@ -1616,7 +1652,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); } @@ -1624,14 +1660,14 @@ 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; 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); } @@ -1639,14 +1675,14 @@ 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; 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); } @@ -1662,13 +1698,13 @@ 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; UNPACK_8_16 (op, dst, val); - LOCAL_SET (dst, SCM_PACK (val)); + SP_SET (dst, SCM_PACK (val)); NEXT (1); } @@ -1677,14 +1713,14 @@ 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; UNPACK_24 (op, dst); val = ip[1]; - LOCAL_SET (dst, SCM_PACK (val)); + SP_SET (dst, SCM_PACK (val)); NEXT (2); } @@ -1692,7 +1728,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; @@ -1706,7 +1742,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); } @@ -1723,7 +1759,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; @@ -1737,7 +1773,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); } @@ -1752,7 +1788,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; @@ -1765,7 +1801,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); } @@ -1775,7 +1811,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; @@ -1786,7 +1822,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); } @@ -1797,7 +1833,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; @@ -1855,14 +1891,14 @@ 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; UNPACK_24 (op, dst); SYNC_IP (); - LOCAL_SET (dst, scm_current_module ()); + SP_SET (dst, scm_current_module ()); NEXT (1); } @@ -1872,7 +1908,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; @@ -1882,27 +1918,30 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (ip[1], sym); SYNC_IP (); - var = scm_lookup (LOCAL_REF (sym)); - CACHE_FP (); + 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); } - /* 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 (61, define, "define!", OP1 (U8_U12_U12)) + 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 (LOCAL_REF (sym), LOCAL_REF (val)); - CACHE_FP (); + var = scm_module_ensure_local_variable (scm_current_module (), + SP_REF (sym)); + CACHE_SP (); + SP_SET (dst, var); NEXT (1); } @@ -1925,7 +1964,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; @@ -1962,14 +2001,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, mod = scm_the_root_module (); var = scm_module_lookup (mod, sym); - CACHE_FP (); + 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); } @@ -1978,7 +2017,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; @@ -2023,7 +2062,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, else var = scm_private_lookup (SCM_CDR (modname), sym); - CACHE_FP (); + CACHE_SP (); if (ip[4] & 0x1) VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym)); @@ -2031,7 +2070,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, *var_loc = var; } - LOCAL_SET (dst, var); + SP_SET (dst, var); NEXT (5); } @@ -2048,7 +2087,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; @@ -2063,10 +2102,11 @@ 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, - LOCAL_REF (tag), - fp - vp->stack_base, - LOCAL_ADDRESS (proc_slot) - vp->stack_base, + SP_REF (tag), + vp->stack_top - vp->fp, + vp->stack_top - FP_SLOT (proc_slot), ip + offset, registers); NEXT (3); @@ -2080,12 +2120,13 @@ 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); + SYNC_IP (); scm_dynstack_push_dynwind (&thread->dynstack, - LOCAL_REF (winder), LOCAL_REF (unwinder)); + SP_REF (winder), SP_REF (unwinder)); NEXT (1); } @@ -2094,7 +2135,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); @@ -2104,14 +2145,15 @@ 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; UNPACK_12_12 (op, fluid, value); + SYNC_IP (); scm_dynstack_push_fluid (&thread->dynstack, - LOCAL_REF (fluid), LOCAL_REF (value), + SP_REF (fluid), SP_REF (value), thread->dynamic_state); NEXT (1); } @@ -2121,7 +2163,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, @@ -2133,59 +2175,58 @@ 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; - SCM fluid, fluids; + SCM fluid; + struct scm_cache_entry *entry; UNPACK_12_12 (op, dst, src); - fluid = LOCAL_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))) + fluid = SP_REF (src); + + /* 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 (); - LOCAL_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)); - LOCAL_SET (dst, val); + SYNC_IP (); + SP_SET (dst, scm_fluid_ref (fluid)); + NEXT (1); } - - NEXT (1); } /* fluid-set fluid:12 val:12 * * 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; - SCM fluid, fluids; + SCM fluid, value; + struct scm_cache_entry *entry; UNPACK_12_12 (op, a, b); - fluid = LOCAL_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))) + fluid = SP_REF (a); + 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, LOCAL_REF (b)); + entry->value = SCM_UNPACK (value); + NEXT (1); } else - SCM_SIMPLE_VECTOR_SET (fluids, num, LOCAL_REF (b)); - - NEXT (1); + { + SYNC_IP (); + scm_fluid_set_x (fluid, value); + NEXT (1); + } } @@ -2199,16 +2240,12 @@ 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))) - RETURN (SCM_I_MAKINUM (scm_i_string_length (str))); - else - { - SYNC_IP (); - RETURN (scm_string_length (str)); - } + VM_VALIDATE_STRING (str, "string-length"); + SP_SET_U64 (dst, scm_i_string_length (str)); + NEXT (1); } /* string-ref dst:8 src:8 idx:8 @@ -2216,37 +2253,38 @@ 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); - 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_uint64 c_idx; + + UNPACK_8_8_8 (op, dst, src, idx); + str = SP_REF (src); + c_idx = SP_REF_U64 (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))); } - /* 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 * * 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; UNPACK_12_12 (op, dst, src); SYNC_IP (); - LOCAL_SET (dst, - scm_string_to_number (LOCAL_REF (src), - SCM_UNDEFINED /* radix = 10 */)); + SP_SET (dst, + scm_string_to_number (SP_REF (src), + SCM_UNDEFINED /* radix = 10 */)); NEXT (1); } @@ -2254,13 +2292,13 @@ 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; 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); } @@ -2268,12 +2306,12 @@ 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); SYNC_IP (); - LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src))); + SP_SET (dst, scm_symbol_to_keyword (SP_REF (src))); NEXT (1); } @@ -2287,9 +2325,10 @@ 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); + SYNC_IP (); RETURN (scm_inline_cons (thread, x, y)); } @@ -2297,7 +2336,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"); @@ -2308,7 +2347,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"); @@ -2319,14 +2358,14 @@ 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; UNPACK_12_12 (op, a, b); - x = LOCAL_REF (a); - y = LOCAL_REF (b); - VM_VALIDATE_PAIR (x, "set-car!"); + x = SP_REF (a); + y = SP_REF (b); + VM_VALIDATE_MUTABLE_PAIR (x, "set-car!"); SCM_SETCAR (x, y); NEXT (1); } @@ -2335,14 +2374,14 @@ 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; UNPACK_12_12 (op, a, b); - x = LOCAL_REF (a); - y = LOCAL_REF (b); - VM_VALIDATE_PAIR (x, "set-car!"); + x = SP_REF (a); + y = SP_REF (b); + VM_VALIDATE_MUTABLE_PAIR (x, "set-cdr!"); SCM_SETCDR (x, y); NEXT (1); } @@ -2358,73 +2397,73 @@ 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); } - /* add1 dst:12 src:12 + /* add/immediate dst:8 src:8 imm:8 * - * Add 1 to the value in SRC, and place the result in DST. + * Add the unsigned 8-bit value IMM to the value from SRC, and place + * the result in DST. */ - VM_DEFINE_OP (82, add1, "add1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (87, add_immediate, "add/immediate", OP1 (X8_S8_S8_C8) | OP_DST) { - ARGS1 (x); + scm_t_uint8 dst, src, imm; + SCM 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)) + UNPACK_8_8_8 (op, dst, src, imm); + x = SP_REF (src); + + if (SCM_LIKELY (SCM_I_INUMP (x))) { - SCM result; + scm_t_signed_bits sum = SCM_I_INUM (x) + (scm_t_signed_bits) imm; - /* 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); + if (SCM_LIKELY (SCM_POSFIXABLE (sum))) + RETURN (SCM_I_MAKINUM (sum)); } - RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (1))); + RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (imm))); } /* sub dst:8 a:8 b:8 * * 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); } - /* sub1 dst:12 src:12 + /* sub/immediate dst:8 src:8 imm:8 * - * Subtract 1 from SRC, and place the result in DST. + * Subtract the unsigned 8-bit value IMM from the value in SRC, and + * place the result in DST. */ - VM_DEFINE_OP (84, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (89, sub_immediate, "sub/immediate", OP1 (X8_S8_S8_C8) | OP_DST) { - ARGS1 (x); + scm_t_uint8 dst, src, imm; + SCM 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)) + UNPACK_8_8_8 (op, dst, src, imm); + x = SP_REF (src); + + if (SCM_LIKELY (SCM_I_INUMP (x))) { - SCM result; + scm_t_signed_bits diff = SCM_I_INUM (x) - (scm_t_signed_bits) imm; - /* 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); + if (SCM_LIKELY (SCM_NEGFIXABLE (diff))) + RETURN (SCM_I_MAKINUM (diff)); } - RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (1))); + RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (imm))); } /* mul dst:8 a:8 b:8 * * 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)); @@ -2434,7 +2473,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)); @@ -2444,7 +2483,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)); @@ -2454,7 +2493,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)); @@ -2464,7 +2503,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)); @@ -2474,7 +2513,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)) @@ -2511,7 +2550,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)) @@ -2524,7 +2563,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)) @@ -2537,7 +2576,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)) @@ -2550,13 +2589,18 @@ 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; + 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_VALIDATE_INDEX (length_val, (size_t) -1, "make-vector"); - LOCAL_SET (dst, scm_make_vector (LOCAL_REF (length), LOCAL_REF (init))); + /* TODO: Inline this allocation. */ + SYNC_IP (); + SP_SET (dst, scm_c_make_vector (length_val, SP_REF (init))); NEXT (1); } @@ -2567,7 +2611,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; @@ -2575,12 +2619,13 @@ 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); + SYNC_IP (); 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); } @@ -2588,12 +2633,12 @@ 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), - vm_error_not_a_vector ("vector-ref", vect)); - RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect))); + VM_VALIDATE_VECTOR (vect, "vector-length"); + SP_SET_U64 (dst, SCM_I_VECTOR_LENGTH (vect)); + NEXT (1); } /* vector-ref dst:8 src:8 idx:8 @@ -2601,17 +2646,19 @@ 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); - 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]); + 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_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]); } /* vector-ref/immediate dst:8 src:8 idx:8 @@ -2619,18 +2666,16 @@ 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; + SCM vect; UNPACK_8_8_8 (op, dst, src, idx); - v = LOCAL_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]); + vect = SP_REF (src); + 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); } @@ -2638,24 +2683,20 @@ 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; - 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); - vect = LOCAL_REF (dst); - idx = LOCAL_REF (idx_var); - val = LOCAL_REF (src); + UNPACK_8_8_8 (op, dst, idx, src); + vect = SP_REF (dst); + 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_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); } @@ -2664,19 +2705,17 @@ 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; 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)); - VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (vect), - vm_error_out_of_range ("vector-ref", scm_from_size_t (idx))); + 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); } @@ -2692,20 +2731,103 @@ 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); + + /* TODO: Specify nfields as untagged value when calling + allocate-struct. */ + SYNC_IP (); + ret = scm_allocate_struct (SP_REF (vtable), + scm_from_uint64 (SP_REF_U64 (nfields))); + SP_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_t_uint64 index; + + UNPACK_8_8_8 (op, dst, src, idx); + + obj = SP_REF (src); + index = SP_REF_U64 (idx); + + if (SCM_LIKELY (SCM_STRUCTP (obj) + && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, + SCM_VTABLE_FLAG_SIMPLE) + && 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, scm_from_uint64 (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; + scm_t_uint64 index; + + UNPACK_8_8_8 (op, dst, idx, src); + + obj = SP_REF (dst); + val = SP_REF (src); + 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) + && index < (SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj), + scm_vtable_index_size)))) + { + SCM_STRUCT_SLOT_SET (obj, index, val); + NEXT (1); + } + + SYNC_IP (); + scm_struct_set_x (obj, scm_from_uint64 (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; @@ -2713,8 +2835,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); } @@ -2724,14 +2846,14 @@ 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; 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, @@ -2749,15 +2871,15 @@ 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; 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, @@ -2780,13 +2902,12 @@ 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)) RETURN (SCM_CLASS_OF (obj)); - SYNC_IP (); - RETURN (scm_class_of (obj)); + RETURN_EXP (scm_class_of (obj)); } @@ -2795,41 +2916,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), + SP_SET (dst, scm_from_contiguous_typed_array (SP_REF (type), + SP_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); + SP_SET (dst, scm_make_typed_array (SP_REF (type), SP_REF (fill), + SP_REF (bounds))); + NEXT (4); } /* bv-u8-ref dst:8 src:8 idx:8 @@ -2846,116 +2971,56 @@ 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); \ + type result; \ + 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); \ - 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)); \ - } \ + 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); \ + NEXT (1); \ } 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) + VM_DEFINE_OP (116, bv_u8_ref, "bv-u8-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (u8, scm_t_uint8, 1, U64); -#define BV_FLOAT_REF(stem, fn_stem, type, size) \ - do { \ - scm_t_signed_bits i; \ - const type *float_ptr; \ - ARGS2 (bv, idx); \ - \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - 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)); \ - else \ - RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ - } while (0) + VM_DEFINE_OP (117, bv_s8_ref, "bv-s8-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (s8, scm_t_int8, 1, S64); - VM_DEFINE_OP (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) - BV_FIXABLE_INT_REF (u8, u8, uint8, 1); + VM_DEFINE_OP (118, bv_u16_ref, "bv-u16-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (u16, scm_t_uint16, 2, U64); - VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) - BV_FIXABLE_INT_REF (s8, s8, int8, 1); + VM_DEFINE_OP (119, bv_s16_ref, "bv-s16-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (s16, scm_t_int16, 2, S64); - VM_DEFINE_OP (110, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST) - BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2); + VM_DEFINE_OP (120, bv_u32_ref, "bv-u32-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (u32, scm_t_uint32, 4, U64); - VM_DEFINE_OP (111, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST) - BV_FIXABLE_INT_REF (s16, s16_native, int16, 2); + VM_DEFINE_OP (121, bv_s32_ref, "bv-s32-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (s32, scm_t_int32, 4, S64); - VM_DEFINE_OP (112, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | 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 (122, bv_u64_ref, "bv-u64-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (u64, scm_t_uint64, 8, U64); - VM_DEFINE_OP (113, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | 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 (123, bv_s64_ref, "bv-s64-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (s64, scm_t_int64, 8, S64); - VM_DEFINE_OP (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) - BV_INT_REF (u64, uint64, 8); + VM_DEFINE_OP (124, bv_f32_ref, "bv-f32-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (f32, float, 4, F64); - VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | 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) - 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) - BV_FLOAT_REF (f64, ieee_double, double, 8); + VM_DEFINE_OP (125, bv_f64_ref, "bv-f64-ref", OP1 (X8_S8_S8_S8) | OP_DST) + BV_REF (f64, double, 8, F64); /* bv-u8-set! dst:8 idx:8 src:8 * bv-s8-set! dst:8 idx:8 src:8 @@ -2971,293 +3036,1012 @@ 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_ ## slot_type slot_val; \ + type val; \ scm_t_uint8 dst, idx, src; \ - scm_t_signed_bits i, j = 0; \ - SCM bv, scm_idx, val; \ - scm_t_ ## type *int_ptr; \ - \ + SCM bv; \ + scm_t_uint64 c_idx; \ UNPACK_8_8_8 (op, dst, idx, src); \ - bv = LOCAL_REF (dst); \ - scm_idx = LOCAL_REF (idx); \ - val = LOCAL_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); \ + bv = SP_REF (dst); \ + c_idx = SP_REF_U64 (idx); \ + slot_val = SP_REF_ ## slot (src); \ \ - 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; \ + VM_VALIDATE_MUTABLE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ \ - UNPACK_8_8_8 (op, dst, idx, src); \ - bv = LOCAL_REF (dst); \ - scm_idx = LOCAL_REF (idx); \ - val = LOCAL_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_uint8 dst, idx, src; \ - scm_t_signed_bits i; \ - SCM bv, scm_idx, val; \ - type *float_ptr; \ - \ - UNPACK_8_8_8 (op, dst, idx, src); \ - bv = LOCAL_REF (dst); \ - scm_idx = LOCAL_REF (idx); \ - val = LOCAL_REF (src); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ - i = SCM_I_INUM (scm_idx); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ + 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_LIKELY (SCM_I_INUMP (scm_idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (float_ptr, type)))) \ - *float_ptr = scm_to_double (val); \ - else \ - { \ - SYNC_IP (); \ - scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, 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); \ NEXT (1); \ } while (0) - VM_DEFINE_OP (118, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8)) - BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1); +#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_MUTABLE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ + \ + 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); \ + } while (0) - VM_DEFINE_OP (119, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8)) - BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1); + VM_DEFINE_OP (126, bv_u8_set, "bv-u8-set!", OP1 (X8_S8_S8_S8)) + BV_BOUNDED_SET (u8, scm_t_uint8, + 0, SCM_T_UINT8_MAX, 1, uint64, U64); - VM_DEFINE_OP (120, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8)) - BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2); + VM_DEFINE_OP (127, bv_s8_set, "bv-s8-set!", OP1 (X8_S8_S8_S8)) + BV_BOUNDED_SET (s8, scm_t_int8, + SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1, int64, S64); - VM_DEFINE_OP (121, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8)) - BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2); + VM_DEFINE_OP (128, bv_u16_set, "bv-u16-set!", OP1 (X8_S8_S8_S8)) + BV_BOUNDED_SET (u16, scm_t_uint16, + 0, SCM_T_UINT16_MAX, 2, uint64, U64); - VM_DEFINE_OP (122, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8)) -#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 (129, bv_s16_set, "bv-s16-set!", OP1 (X8_S8_S8_S8)) + BV_BOUNDED_SET (s16, scm_t_int16, + SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2, int64, S64); - VM_DEFINE_OP (123, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8)) -#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 (130, bv_u32_set, "bv-u32-set!", OP1 (X8_S8_S8_S8)) + BV_BOUNDED_SET (u32, scm_t_uint32, + 0, SCM_T_UINT32_MAX, 4, uint64, U64); - VM_DEFINE_OP (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) - BV_INT_SET (u64, uint64, 8); + VM_DEFINE_OP (131, bv_s32_set, "bv-s32-set!", OP1 (X8_S8_S8_S8)) + BV_BOUNDED_SET (s32, scm_t_int32, + SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4, int64, S64); - VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) - BV_INT_SET (s64, int64, 8); + VM_DEFINE_OP (132, bv_u64_set, "bv-u64-set!", OP1 (X8_S8_S8_S8)) + BV_SET (u64, scm_t_uint64, 8, U64); - VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) - BV_FLOAT_SET (f32, ieee_single, float, 4); + VM_DEFINE_OP (133, bv_s64_set, "bv-s64-set!", OP1 (X8_S8_S8_S8)) + BV_SET (s64, scm_t_int64, 8, S64); - VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8)) - BV_FLOAT_SET (f64, ieee_double, double, 8); + VM_DEFINE_OP (134, bv_f32_set, "bv-f32-set!", OP1 (X8_S8_S8_S8)) + BV_SET (f32, float, 4, F64); - /* br-if-logtest a:12 b:12 invert:1 _:7 offset:24 + VM_DEFINE_OP (135, bv_f64_set, "bv-f64-set!", OP1 (X8_S8_S8_S8)) + BV_SET (f6, double, 8, F64); + + /* scm->f64 dst:12 src:12 * - * 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. + * 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 (128, br_if_logtest, "br-if-logtest", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (136, scm_to_f64, "scm->f64", OP1 (X8_S12_S12) | OP_DST) { - 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); - + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); SYNC_IP (); - ret = scm_allocate_struct (LOCAL_REF (vtable), LOCAL_REF (nfields)); - LOCAL_SET (dst, ret); - + SP_SET_F64 (dst, scm_to_double (SP_REF (src))); NEXT (1); } - /* struct-ref dst:8 src:8 idx:8 + /* f64->scm dst:12 src:12 * - * Fetch the item at slot IDX in the struct in SRC, and store it - * in DST. + * Pack a raw double-precision floating point value into an inexact + * number allocated on the heap. */ - VM_DEFINE_OP (130, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (137, f64_to_scm, "f64->scm", OP1 (X8_S12_S12) | 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))); - + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); SYNC_IP (); - RETURN (scm_struct_ref (obj, index)); + SP_SET (dst, scm_from_double (SP_REF_F64 (src))); + NEXT (1); } - /* struct-set! dst:8 idx:8 src:8 + /* fadd dst:8 a:8 b:8 * - * Store SRC into the struct DST at slot IDX. + * 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 (131, struct_set, "struct-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (138, fadd, "fadd", OP1 (X8_S8_S8_S8) | OP_DST) { - scm_t_uint8 dst, idx, src; - SCM obj, val, index; + 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); + } - UNPACK_8_8_8 (op, dst, idx, src); + /* 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); + } - obj = LOCAL_REF (dst); - val = LOCAL_REF (src); - index = LOCAL_REF (idx); + /* 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); + } - 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)))) + /* 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); + } + + /* 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)) { - SCM_STRUCT_SLOT_SET (obj, SCM_I_INUM (index), val); - NEXT (1); + 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); + } + + /* 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 (); - scm_struct_set_x (obj, index, val); + 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); + } + + /* 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); + } + + /* 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 (==); + } + + /* 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 (<); + } + + VM_DEFINE_OP (148, br_if_u64_le, "br-if-u64-<=", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_ARITHMETIC (<=); + } + + /* 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); + } + + /* 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); + } + + /* 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); + } + + /* 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); + } + + /* 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); + } + + /* 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))); + } + + /* 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); + 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); + } + + /* 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); + } + +#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. */ \ + 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. */ \ + 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); + } + + /* 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); + + 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)); + + 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); + + VM_VALIDATE_CHAR (x, "char->integer"); + SP_SET_U64 (dst, SCM_CHAR (x)); + + NEXT (1); + } + + /* 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); + } + + /* 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); + } + + /* handle-interrupts _:24 + * + * Handle pending interrupts. + */ + VM_DEFINE_OP (183, handle_interrupts, "handle-interrupts", OP1 (X32)) + { + 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); + } + + /* 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); + } + + /* 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 (>=); + } + + /* 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 (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) - VM_DEFINE_OP (139, unused_139, NULL, NOP) - VM_DEFINE_OP (140, unused_140, NULL, NOP) - VM_DEFINE_OP (141, unused_141, NULL, NOP) - VM_DEFINE_OP (142, unused_142, NULL, NOP) - VM_DEFINE_OP (143, unused_143, NULL, NOP) - VM_DEFINE_OP (144, unused_144, NULL, NOP) - VM_DEFINE_OP (145, unused_145, NULL, NOP) - VM_DEFINE_OP (146, unused_146, NULL, NOP) - VM_DEFINE_OP (147, unused_147, NULL, NOP) - VM_DEFINE_OP (148, unused_148, NULL, NOP) - VM_DEFINE_OP (149, unused_149, NULL, NOP) - VM_DEFINE_OP (150, unused_150, NULL, NOP) - VM_DEFINE_OP (151, unused_151, NULL, NOP) - VM_DEFINE_OP (152, unused_152, NULL, NOP) - VM_DEFINE_OP (153, unused_153, NULL, NOP) - VM_DEFINE_OP (154, unused_154, NULL, NOP) - VM_DEFINE_OP (155, unused_155, NULL, NOP) - VM_DEFINE_OP (156, unused_156, NULL, NOP) - VM_DEFINE_OP (157, unused_157, NULL, NOP) - VM_DEFINE_OP (158, unused_158, NULL, NOP) - VM_DEFINE_OP (159, unused_159, NULL, NOP) - VM_DEFINE_OP (160, unused_160, NULL, NOP) - VM_DEFINE_OP (161, unused_161, NULL, NOP) - 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) - VM_DEFINE_OP (168, unused_168, NULL, NOP) - VM_DEFINE_OP (169, unused_169, NULL, NOP) - 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) - VM_DEFINE_OP (175, unused_175, NULL, NOP) - VM_DEFINE_OP (176, unused_176, NULL, NOP) - VM_DEFINE_OP (177, unused_177, NULL, NOP) - 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) - VM_DEFINE_OP (183, unused_183, NULL, NOP) - 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) - 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) - VM_DEFINE_OP (192, unused_192, NULL, NOP) VM_DEFINE_OP (193, unused_193, NULL, NOP) VM_DEFINE_OP (194, unused_194, NULL, NOP) VM_DEFINE_OP (195, unused_195, NULL, NOP) @@ -3353,16 +4137,17 @@ 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 #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 @@ -3381,6 +4166,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 0e5983575..18f219249 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 @@ -37,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/cache-internal.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; @@ -65,7 +65,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 +74,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); } @@ -107,9 +109,9 @@ vm_restore_sp (struct scm_vm *vp, SCM *new_sp) void scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#", port); + scm_puts (">", port); } int @@ -118,8 +120,8 @@ scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame) struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont); 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 = data->fp_offset; + frame->sp_offset = data->stack_size; frame->ip = data->ra; return 1; @@ -129,23 +131,23 @@ 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; + p->fp_offset = stack_top - fp; + memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom)); 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,44 +164,30 @@ 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; - 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)); - vp->fp = cp->fp + reloc; - memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); - vm_restore_sp (vp, cp->sp + reloc); - - if (reloc) - { - SCM *fp = vp->fp; - while (fp) - { - SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); - if (next_fp) - { - next_fp += reloc; - SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp); - } - fp = next_fp; - } - } + 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; } 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 +196,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].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; } @@ -238,19 +217,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 +256,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 +279,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].as_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].as_scm, args); scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); } @@ -322,11 +304,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,45 +317,33 @@ 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].as_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 { struct scm_vm *vp; struct scm_vm_cont *cp; - scm_t_ptrdiff reloc; }; static void * @@ -382,58 +352,45 @@ 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; - scm_t_ptrdiff reloc; - base = SCM_FRAME_LOCALS_ADDRESS (vp->fp); - reloc = cp->reloc + (base - cp->stack_base); + memcpy (vp->fp - cp->stack_size, + cp->stack_bottom, + cp->stack_size * sizeof (*cp->stack_bottom)); - memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); - - vp->fp = cp->fp + reloc; + vp->fp -= cp->fp_offset; 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)) - SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc); - } - - data->reloc = reloc; - return NULL; } 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; - scm_t_ptrdiff reloc; - size_t i; + union scm_vm_stack_element *args; + scm_t_ptrdiff old_fp_offset; - 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); + 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; - /* 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].as_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 @@ -448,7 +405,7 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, 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); } @@ -463,27 +420,29 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, 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; +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_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_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; +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_out_of_range (const char *subr, SCM k) 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; 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) @@ -508,14 +467,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) { @@ -531,11 +482,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 @@ -554,12 +505,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) { @@ -574,15 +519,9 @@ vm_error_wrong_type_apply (SCM proc) } static void -vm_error_stack_underflow (void) +vm_error_not_a_char (const char *subr, SCM x) { - 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); + scm_wrong_type_arg_msg (subr, 1, x, "char"); } static void @@ -591,12 +530,36 @@ 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) +{ + 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) { 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) { @@ -610,10 +573,21 @@ vm_error_not_a_vector (const char *subr, SCM x) } static void -vm_error_out_of_range (const char *subr, SCM k) +vm_error_not_a_mutable_vector (const char *subr, SCM x) { - scm_to_size_t (k); - scm_out_of_range (subr, k); + 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) +{ + 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 @@ -642,12 +616,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)); -} - @@ -662,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 */ @@ -681,9 +653,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) }; @@ -692,6 +664,19 @@ 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) +{ + return ip == vm_boot_continuation_code; +} static SCM scm_vm_builtin_ref (unsigned idx) @@ -789,20 +774,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 +797,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 +814,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 +858,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 = vp->stack_top; + 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,58 +885,58 @@ 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 } -#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; } @@ -957,48 +944,63 @@ 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. */ +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) { - SCM *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; - struct dead_slot_map_cache cache; + union scm_vm_stack_element *sp, *fp; + /* 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 slot_map_cache cache; 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)) { - 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 (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; - continue; - } - } + enum slot_desc desc = SLOT_DESC_LIVE_SCM; - mark_stack_ptr = GC_mark_and_push ((void *) elt, - 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); @@ -1006,7 +1008,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); @@ -1018,8 +1020,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 +1029,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,44 +1038,30 @@ 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; - if (vp->fp) - vp->fp += reloc; - data->new_sp += reloc; - fp = vp->fp; - while (fp) - { - SCM *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_stack; + return new_bottom; } static scm_t_ptrdiff @@ -1095,9 +1083,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 +1115,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 +1134,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 +1172,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 +1197,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,34 +1211,41 @@ 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]; { - int resume = SCM_I_SETJMP (registers); - + scm_i_jmp_buf 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 (); @@ -1255,7 +1253,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; } } @@ -1449,7 +1451,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 +1476,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..a1cac391f 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,15 +37,17 @@ 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 */ + const void *resumable_prompt_cookie; /* opaque cookie */ int engine; /* which vm engine we're using */ }; @@ -78,13 +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 { - SCM *sp; - SCM *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; - SCM *stack_base; - scm_t_ptrdiff reloc; + /* Stack bottom, which also keeps saved stack alive for GC. */ + union scm_vm_stack_element *stack_bottom; + /* 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; }; @@ -97,13 +105,16 @@ 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); 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); diff --git a/libguile/vports.c b/libguile/vports.c index 17eac8695..29531cfb6 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -22,6 +22,7 @@ # include #endif +#include #include #include @@ -31,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" @@ -49,103 +49,105 @@ */ -static scm_t_bits scm_tc16_sfport; +static scm_t_port_type *scm_soft_port_type; + +#define ENCODE_BUF_SIZE 10 + +struct soft_port { + SCM write_char; + SCM write_string; + SCM flush; + SCM read_char; + SCM close; + SCM input_waiting; + scm_t_uint8 encode_buf[ENCODE_BUF_SIZE]; + size_t encode_cur; + size_t encode_end; +}; +/* Sadly it seems that most code expects there to be no write buffering + at all. */ static void -sf_flush (SCM port) +soft_port_get_natural_buffer_sizes (SCM port, size_t *read_size, + size_t *write_size) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - SCM stream = SCM_PACK (pt->stream); - - SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2); - - if (scm_is_true (f)) - scm_call_0 (f); - + *write_size = 1; } -static void -sf_write (SCM port, const void *data, size_t size) +static size_t +soft_port_write (SCM port, SCM src, size_t start, size_t count) { - SCM p = SCM_PACK (SCM_STREAM (port)); + struct soft_port *stream = (void *) SCM_STREAM (port); + signed char * ptr = SCM_BYTEVECTOR_CONTENTS (src) + start; - /* 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_from_locale_stringn ((char *) data, size)); + 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; } -/* 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 -sf_fill_input (SCM port) +static size_t +soft_port_read (SCM port, SCM dst, size_t start, size_t count) { - SCM p = SCM_PACK (SCM_STREAM (port)); - SCM ans; - scm_t_wchar c; - scm_t_port_internal *pti; + size_t written; + struct soft_port *stream = (void *) SCM_STREAM (port); + signed char *dst_ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start; - 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"); - 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 (stream->encode_cur == stream->encode_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 0; + 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); + stream->encode_cur = 0; + stream->encode_end = len; + memcpy (stream->encode_buf, str, len); + free (str); } - return c; + for (written = 0; + written < count && stream->encode_cur < stream->encode_end; + written++, stream->encode_cur++) + dst_ptr[written] = stream->encode_buf[stream->encode_cur]; + + return written; +} + + +static void +soft_port_close (SCM port) +{ + struct soft_port *stream = (void *) SCM_STREAM (port); + if (scm_is_true (stream->close)) + scm_call_0 (stream->close); } static int -sf_close (SCM port) +soft_port_input_waiting (SCM port) { - SCM p = SCM_PACK (SCM_STREAM (port)); - SCM f = SCM_SIMPLE_VECTOR_REF (p, 4); - if (scm_is_false (f)) - return 0; - f = scm_call_0 (f); - errno = 0; - return scm_is_false (f) ? EOF : 0; -} - - -static int -sf_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,38 +204,47 @@ 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); vlen = SCM_SIMPLE_VECTOR_LENGTH (pv); 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), - SCM_UNPACK (pv)); - scm_port_non_buffer (SCM_PTAB_ENTRY (z)); - return z; + 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; + + 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", sf_fill_input, sf_write); + scm_t_port_type *ptob = scm_make_port_type ("soft", soft_port_read, + soft_port_write); - scm_set_port_flush (tc, sf_flush); - scm_set_port_close (tc, sf_close); - scm_set_port_input_waiting (tc, sf_input_waiting); + 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 (ptob, soft_port_input_waiting); - return tc; + return ptob; } void scm_init_vports () { - scm_tc16_sfport = scm_make_sfptob (); + scm_soft_port_type = scm_make_sfptob (); #include "libguile/vports.x" } diff --git a/libguile/root.h b/libguile/weak-list.h similarity index 52% rename from libguile/root.h rename to libguile/weak-list.h index 68ab5c7ce..989cb7f0a 100644 --- a/libguile/root.h +++ b/libguile/weak-list.h @@ -1,9 +1,9 @@ /* classes: h_files */ -#ifndef SCM_ROOT_H -#define SCM_ROOT_H +#ifndef SCM_WEAK_LIST_H +#define SCM_WEAK_LIST_H -/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc. +/* 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 @@ -24,22 +24,47 @@ #include "libguile/__scm.h" -#include "libguile/debug.h" -#include "libguile/throw.h" +#include "libguile/weak-vector.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); +static inline SCM +scm_i_weak_cons (SCM car, SCM cdr) +{ + return scm_cons (scm_c_make_weak_vector (1, car), cdr); +} -#endif /* SCM_ROOT_H */ +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: diff --git a/libguile/weak-set.c b/libguile/weak-set.c index e8523ba62..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" @@ -675,12 +676,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_unlocked ('/', port); + scm_putc ('/', port); scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port); - scm_puts_unlocked (">", port); + scm_puts (">", port); } static void @@ -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 4e3ed3396..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" @@ -686,6 +687,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 @@ -790,12 +801,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_unlocked ('/', port); + scm_putc ('/', port); scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port); - scm_puts_unlocked (">", port); + scm_puts (">", port); } static void @@ -822,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) { @@ -829,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; } @@ -912,9 +936,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); @@ -1148,6 +1169,8 @@ void scm_init_weak_table () { #include "libguile/weak-table.x" + + scm_i_register_async_gc_callback (vacuum_all_weak_tables); } /* diff --git a/libguile/win32-uname.c b/libguile/win32-uname.c deleted file mode 100644 index 5349f1410..000000000 --- a/libguile/win32-uname.c +++ /dev/null @@ -1,146 +0,0 @@ -/* Copyright (C) 2001, 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 - */ - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include "libguile/__scm.h" - -#include -#include -#include - -#include "win32-uname.h" - -/* - * Get name and information about current kernel. - */ -int -uname (struct utsname *uts) -{ - enum { WinNT, Win95, Win98, WinUnknown }; - OSVERSIONINFO osver; - SYSTEM_INFO sysinfo; - DWORD sLength; - DWORD os = WinUnknown; - - memset (uts, 0, sizeof (*uts)); - - osver.dwOSVersionInfoSize = sizeof (osver); - GetVersionEx (&osver); - GetSystemInfo (&sysinfo); - - switch (osver.dwPlatformId) - { - case VER_PLATFORM_WIN32_NT: /* NT, Windows 2000 or Windows XP */ - if (osver.dwMajorVersion == 4) - strcpy (uts->sysname, "Windows NT4x"); /* NT4x */ - else if (osver.dwMajorVersion <= 3) - 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) - strcpy (uts->sysname, "Windows XP"); /* XP */ - os = WinNT; - break; - - case VER_PLATFORM_WIN32_WINDOWS: /* Win95, Win98 or WinME */ - 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 */ - os = Win98; - } - else - { - strcpy (uts->sysname, "Windows 95"); /* 95 */ - os = Win95; - } - break; - - case VER_PLATFORM_WIN32s: /* Windows 3.x */ - strcpy (uts->sysname, "Windows"); - break; - } - - sprintf (uts->version, "%ld.%02ld", - osver.dwMajorVersion, osver.dwMinorVersion); - - if (osver.szCSDVersion[0] != '\0' && - (strlen (osver.szCSDVersion) + strlen (uts->version) + 1) < - sizeof (uts->version)) - { - strcat (uts->version, " "); - strcat (uts->version, osver.szCSDVersion); - } - - sprintf (uts->release, "build %ld", osver.dwBuildNumber & 0xFFFF); - - switch (sysinfo.wProcessorArchitecture) - { - case PROCESSOR_ARCHITECTURE_PPC: - strcpy (uts->machine, "ppc"); - break; - case PROCESSOR_ARCHITECTURE_ALPHA: - strcpy (uts->machine, "alpha"); - break; - case PROCESSOR_ARCHITECTURE_MIPS: - strcpy (uts->machine, "mips"); - break; - case PROCESSOR_ARCHITECTURE_INTEL: - /* - * dwProcessorType is only valid in Win95 and Win98 and WinME - * wProcessorLevel is only valid in WinNT - */ - switch (os) - { - case Win95: - case Win98: - switch (sysinfo.dwProcessorType) - { - case PROCESSOR_INTEL_386: - case PROCESSOR_INTEL_486: - case PROCESSOR_INTEL_PENTIUM: - sprintf (uts->machine, "i%ld", sysinfo.dwProcessorType); - break; - default: - strcpy (uts->machine, "i386"); - break; - } - break; - case WinNT: - sprintf (uts->machine, "i%d86", sysinfo.wProcessorLevel); - break; - default: - strcpy (uts->machine, "unknown"); - break; - } - break; - default: - strcpy (uts->machine, "unknown"); - break; - } - - sLength = sizeof (uts->nodename) - 1; - GetComputerName (uts->nodename, &sLength); - return 0; -} diff --git a/libguile/win32-uname.h b/libguile/win32-uname.h deleted file mode 100644 index 4b7498133..000000000 --- a/libguile/win32-uname.h +++ /dev/null @@ -1,52 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_WIN32_UNAME_H -#define SCM_WIN32_UNAME_H - -/* Copyright (C) 2001, 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 _UTSNAME_LENGTH 65 -#define _UTSNAME_NODENAME_LENGTH _UTSNAME_LENGTH -#define _UTSNAME_DOMAIN_LENGTH _UTSNAME_LENGTH - -/* Structure describing the system and machine. */ -struct utsname -{ - /* Name of the implementation of the operating system. */ - char sysname[_UTSNAME_LENGTH]; - - /* Name of this node on the network. */ - char nodename[_UTSNAME_NODENAME_LENGTH]; - - /* Current release level of this implementation. */ - char release[_UTSNAME_LENGTH]; - - /* Current version level of this release. */ - char version[_UTSNAME_LENGTH]; - - /* Name of the hardware type the system is running on. */ - char machine[_UTSNAME_LENGTH]; - - /* Name of the domain of this node on the network. */ - char domainname[_UTSNAME_DOMAIN_LENGTH]; -}; - -int uname (struct utsname * uts); - -#endif /* SCM_WIN32_UNAME_H */ diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4 index 8eca5518a..bb3512fd5 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-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 ce3e39e9b..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-2014 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/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 +]) diff --git a/m4/alloca.m4 b/m4/alloca.m4 index d7bdea631..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-2014 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 f01699a9d..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-2014 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 00d870930..f5f2a1899 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-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 99889445f..102180938 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-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 6d6357cbe..f20d0f490 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-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 ace455661..c04ff8dd0 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-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, @@ -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..f58a99899 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-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 a3894aa64..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-2014 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 be36a42b8..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-2014 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 68510c5c5..005a43ae1 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-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/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..b783296b6 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-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 1bb2d6fb9..a39de0171 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-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 3f2b16b12..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-2014 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 b42276948..b4ec3d191 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-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. @@ -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..46f5394c7 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-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 937f4bca9..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-2014 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 89638a0bf..bdb9ae250 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-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. @@ -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..b5efd246b 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-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. @@ -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..96b9bca5a 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-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 cfabe46f5..3b9fa5f58 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-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 4ee9e6a14..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-2014 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 7bee63571..cd64b92d0 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-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 b2dfeef96..54f609e5a 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-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 d6f4ba7ff..c9cb81dd8 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-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 37f55ca3d..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-2014 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 @@ -72,6 +72,34 @@ dnl configure.ac when using autoheader 2.62. #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 @@ -101,6 +129,13 @@ dnl configure.ac when using autoheader 2.62. AC_DEFINE([_DARWIN_C_SOURCE]) AC_DEFINE([_GNU_SOURCE]) 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 240150efb..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-2014 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. @@ -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..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-2014 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 fb2556d37..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-2014 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 new file mode 100644 index 000000000..35580ac27 --- /dev/null +++ b/m4/flexmember.m4 @@ -0,0 +1,43 @@ +# serial 4 +# Check for flexible array member support. + +# 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. + +# 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 (); + 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], + [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..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-2014 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 ad2d1290c..5b3544df2 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-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 a38c03d14..713e7b346 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-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 729afe859..69579d82a 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-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 579826213..73f50b3e3 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-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 ddd3fb976..14c871a8b 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-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 888a65def..f1399de39 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-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 0ab14c9e4..bd429eeae 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-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 2e6658486..f5e228471 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. +# 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 47b8f0897..c013fdd47 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. +# 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 1c2d66ee2..4f501e5bf 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-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 ab58b7121..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-2014 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 26c96b3e3..01f82d59b 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-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 @@ -27,12 +27,12 @@ # 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 --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 @@ -47,6 +47,7 @@ gl_MODULES([ connect copysign dirfd + dirname-lgpl duplocale environ extensions @@ -76,7 +77,6 @@ gl_MODULES([ isfinite isinf isnan - largefile ldexp lib-symbol-versions lib-symbol-visibility @@ -91,7 +91,7 @@ gl_MODULES([ malloc-gnu malloca mkdir - mkstemp + mkostemp nl_langinfo nproc open @@ -127,7 +127,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([]) @@ -136,6 +136,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..7d9b40b79 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-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. @@ -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..290d77933 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-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 @@ -37,20 +37,26 @@ 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: + # Code from module accept4: # Code from module alignof: # Code from module alloca: # 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: # 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: @@ -73,10 +79,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 +108,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: @@ -111,7 +118,7 @@ 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: # Code from module isnan: @@ -128,6 +135,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: @@ -146,7 +154,9 @@ 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: # Code from module msvc-nothrow: # Code from module multiarch: @@ -188,7 +198,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: @@ -220,16 +229,12 @@ 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: - # 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: # Code from module vc-list-files: @@ -240,6 +245,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: ]) @@ -262,10 +268,8 @@ 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_ACCEPT4 + gl_SYS_SOCKET_MODULE_INDICATOR([accept4]) gl_FUNC_ALLOCA gl_HEADER_ARPA_INET AC_PROG_MKDIR_P @@ -274,12 +278,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 +291,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 +310,14 @@ 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]) @@ -355,7 +347,7 @@ AC_SUBST([LTALLOCA]) 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 @@ -386,6 +378,7 @@ AC_SUBST([LTALLOCA]) 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]) @@ -401,8 +394,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 +410,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])]) @@ -445,7 +435,6 @@ AC_SUBST([LTALLOCA]) 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]) @@ -467,11 +456,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 +465,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,17 +474,13 @@ 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 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]) @@ -520,17 +495,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,45 +521,22 @@ 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]) 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_MSVC_INVAL + 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 - gl_MSVC_NOTHROW + AC_REQUIRE([gl_MSVC_NOTHROW]) if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then AC_LIBOBJ([msvc-nothrow]) fi @@ -615,7 +556,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 +576,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 +613,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 +630,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 +646,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 +660,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 +671,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 +681,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 +693,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,35 +710,709 @@ AC_SUBST([LTALLOCA]) fi gl_MATH_MODULE_INDICATOR([trunc]) gl_UNISTD_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]) - 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], [unitypes.h]) - gl_FUNC_VASNPRINTF 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_37f71b604aa9c54446783d80f42fe547=false + gl_gnulib_enabled_chdir=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_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_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 + gl_UNISTD_MODULE_INDICATOR([chdir]) + gl_gnulib_enabled_chdir=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 + 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_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 + 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 + 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_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 $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 $HAVE_COPYSIGN = 0; then + func_gl_gnulib_m4code_signbit + fi + if test $gl_func_frexp != yes; then + func_gl_gnulib_m4code_b1df7117b479d2da59d76deba468ee21 + 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 $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 $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_stat + fi + if test $HAVE_MKOSTEMP = 0; 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_sockets + fi + if test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1; then + func_gl_gnulib_m4code_stat + 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_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 + 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_9bc5f216d57e231e4834049d67d0db62 + 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_sockets + 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_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_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]) + 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_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 +1459,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])[ || @@ -989,17 +1560,19 @@ 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 doc/gendocs_template + doc/gendocs_template_min lib/accept.c + lib/accept4.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 @@ -1029,6 +1602,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 @@ -1049,6 +1623,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 +1637,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 @@ -1073,6 +1650,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 @@ -1095,7 +1673,9 @@ 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 lib/msvc-inval.h lib/msvc-nothrow.c @@ -1181,22 +1761,16 @@ 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 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 lib/verify.h @@ -1207,14 +1781,17 @@ 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 m4/absolute-header.m4 + m4/accept4.m4 m4/alloca.m4 m4/arpa_inet_h.m4 m4/autobuild.m4 m4/btowc.m4 + m4/builtin-expect.m4 m4/byteswap.m4 m4/canonicalize.m4 m4/ceil.m4 @@ -1240,6 +1817,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 +1831,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 @@ -1261,7 +1840,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 @@ -1277,8 +1855,8 @@ 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/limits-h.m4 m4/link.m4 m4/localcharset.m4 m4/locale-fr.m4 @@ -1300,7 +1878,8 @@ 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 m4/msvc-inval.m4 @@ -1365,6 +1944,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..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-2014 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 new file mode 100644 index 000000000..d79acd658 --- /dev/null +++ b/m4/hard-locale.m4 @@ -0,0 +1,11 @@ +# hard-locale.m4 serial 8 +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. + +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..595a68d0c 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-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 4b29c5f2c..bdafc54e3 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 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, 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 @@ -255,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 e992fa399..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-2014 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 31ced265a..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-2014 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 e0bfd7203..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-2014 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 69ad3dbb0..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-2014 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 5b27759c5..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-2014 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 136ed24d0..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-2014 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/inline.m4 b/m4/inline.m4 deleted file mode 100644 index c49957f80..000000000 --- a/m4/inline.m4 +++ /dev/null @@ -1,40 +0,0 @@ -# inline.m4 serial 4 -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. - -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/intmax_t.m4 b/m4/intmax_t.m4 index af5561e5d..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-2014 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 87be9cfb5..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-2014 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 53ad9092a..fab12be86 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-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. @@ -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..146529d9d 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-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. @@ -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..844aac279 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-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 36e4ea307..cbe6a38e1 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-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 1f2717d5e..1a0d03e63 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-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 98b2b69fc..a42cfc075 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-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. @@ -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..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-2014 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 a1b564ad9..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-2014 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 f8b4a5c51..caccec11b 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-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. @@ -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 <= 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])]) diff --git a/m4/libunistring.m4 b/m4/libunistring.m4 index 35980dd0b..024989693 100644 --- a/m4/libunistring.m4 +++ b/m4/libunistring.m4 @@ -1,5 +1,5 @@ # libunistring.m4 serial 11 -dnl Copyright (C) 2009-2014 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 e923d0d02..021c30140 100644 --- a/m4/link.m4 +++ b/m4/link.m4 @@ -1,5 +1,5 @@ # link.m4 serial 8 -dnl Copyright (C) 2009-2014 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 ada2f01f6..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-2014 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 27db5ab87..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-2014 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 c88fe8b4e..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-2014 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 d3b234742..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-2014 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 283858843..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-2014 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 1fd291952..c287aa526 100644 --- a/m4/localeconv.m4 +++ b/m4/localeconv.m4 @@ -1,5 +1,5 @@ # localeconv.m4 serial 1 -dnl Copyright (C) 2012-2014 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 146a96f5b..90dee2403 100644 --- a/m4/log.m4 +++ b/m4/log.m4 @@ -1,5 +1,5 @@ # log.m4 serial 4 -dnl Copyright (C) 2011-2014 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 25440b0ec..f55ac549e 100644 --- a/m4/log1p.m4 +++ b/m4/log1p.m4 @@ -1,5 +1,5 @@ # log1p.m4 serial 3 -dnl Copyright (C) 2012-2014 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 eefb37c45..9a3294bc2 100644 --- a/m4/longlong.m4 +++ b/m4/longlong.m4 @@ -1,5 +1,5 @@ # longlong.m4 serial 17 -dnl Copyright (C) 1999-2007, 2009-2014 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 c5e72b81e..953c117d8 100644 --- a/m4/lstat.m4 +++ b/m4/lstat.m4 @@ -1,6 +1,6 @@ -# serial 26 +# serial 27 -# Copyright (C) 1997-2001, 2003-2014 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, @@ -37,30 +37,28 @@ AC_DEFUN([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK], [gl_cv_func_lstat_dereferences_slashed_symlink], [rm -f conftest.sym conftest.file echo >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..e1d2ec687 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-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. 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..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-2014 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 9e2adfbac..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-2014 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 6f0e6aacd..b55ebc772 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-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 a9d157092..536183f4f 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-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, @@ -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 ]) @@ -147,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; }]])], @@ -207,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; }]])], @@ -335,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; }]])], @@ -522,7 +539,7 @@ int main () memset (&state, '\0', sizeof (mbstate_t)); if (mbrtowc (&wc, "", 1, &state) != 0) - return 1; + return 2; } return 0; }]])], @@ -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 2; + 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 3; + } + 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..5904a5107 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-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 068155a52..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-2014 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 cacfe1610..378a4e258 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-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 b9f126cfa..b6ec81401 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-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 51e78c13d..5eec622ef 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-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 new file mode 100644 index 000000000..337f17b5c --- /dev/null +++ b/m4/mkostemp.m4 @@ -0,0 +1,23 @@ +# mkostemp.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_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 9033a4e60..000000000 --- a/m4/mkstemp.m4 +++ /dev/null @@ -1,82 +0,0 @@ -#serial 23 - -# 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. - -# 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/m4/mktime.m4 b/m4/mktime.m4 new file mode 100644 index 000000000..d594ddc58 --- /dev/null +++ b/m4/mktime.m4 @@ -0,0 +1,268 @@ +# serial 27 +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, +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..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-2014 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 db6e192be..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-2014 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 7f26087e7..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-2014 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 9e32c171e..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-2014 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 2cb956dee..30006cb33 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-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 cd7d48291..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-2014 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 1d447d6f1..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-2014 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 6976e7767..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-2014 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 5a5d77d63..2c2c5fb45 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-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. @@ -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..e1ca5b397 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. +# 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 f5885b34b..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-2014 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 68f116f0a..2a869dc6b 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-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 114f91f04..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-2014 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 d3532d5dd..c35b32c50 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-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 1cff1fef0..7393343c5 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-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 f523b1873..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-2014 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 fcfe7fa4d..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-2014 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 9346ab041..a44ac66b8 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-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 @@ -61,7 +63,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 +222,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 +330,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 +367,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 +429,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 +575,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 +1123,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 +1222,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 +1303,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 +1445,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..a8e3ab33d 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-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 8656578ef..28c2e0b5c 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-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 176b0b04d..36249abdc 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-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 f9ce868c2..d3ba0ad42 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-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 08bd46a96..61ff09872 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-2017 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..7c3ffe7c2 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-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 db6a9399c..f585c2769 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-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 13049b7cf..45b7df459 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-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 f0c42e08f..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-2014 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 66648bbb5..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-2014 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 149888df4..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-2014 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. @@ -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..c7844bc8e 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-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,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..89331e23a 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-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 0f46a7bec..005aa8cfe 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-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 c8f664fbf..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-2014 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 9ed48c780..9d2b0a8db 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-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 7e192d5e9..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-2014 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 888db35c0..e5155f798 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. +# 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 041498baf..c708fd260 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-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 da6ff7427..0ef23bc32 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-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 4c07f864c..0a62f49d6 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-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 31d436f0e..c2e258215 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-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 fbe1d0687..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-2014 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 ea5c4fc59..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-2014 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 1ae327b36..9ff77df9e 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-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 9efafe5c5..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-2014 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. @@ -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..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-2014 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 5 +#serial 7 # Prepare for substituting if it is not supported. @@ -43,56 +43,64 @@ 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" + + #ifdef __cplusplus + typedef bool Bool; + #else + typedef _Bool Bool; + #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 - 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 c555e2952..f45def101 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-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. @@ -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..4ac854d51 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 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 @@ -70,6 +73,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) @@ -150,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))) @@ -218,6 +232,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 @@ -278,28 +294,74 @@ 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 - STDINT_H= + 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([[ +#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 + 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"]) ]) @@ -467,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 ]) @@ -477,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 7fc2ce9a8..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-2014 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 d15913a3c..9ffbb852e 100644 --- a/m4/stdio_h.m4 +++ b/m4/stdio_h.m4 @@ -1,14 +1,45 @@ -# stdio_h.m4 serial 43 -dnl Copyright (C) 2007-2014 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], [ + 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]) + 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..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-2014 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]) ]) @@ -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]) @@ -84,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]) @@ -107,6 +109,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..a92dbd63b 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-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 0ba3dd074..3a5db9b4e 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-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 64e683f9d..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-2014 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 ad78efb9c..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-2014 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 1a502b4eb..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-2014 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 114d82817..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-2014 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 eaa7642ba..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-2014 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 5c79300f8..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-2014 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. @@ -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..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-2014 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 9748905b5..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-2014 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 ba6b4b5ed..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-2014 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 1594e1f5d..a59f4c086 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-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 9852778f9..b92567875 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-2017 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..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-2014 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 new file mode 100644 index 000000000..79060e00f --- /dev/null +++ b/m4/time_rz.m4 @@ -0,0 +1,21 @@ +dnl Time zone functions: tzalloc, localtime_rz, etc. + +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. + +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..510e25ab4 --- /dev/null +++ b/m4/timegm.m4 @@ -0,0 +1,26 @@ +# timegm.m4 serial 11 +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. + +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..57570de43 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-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 486351b47..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-2014 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 ba87bd0c0..a070d7828 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-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 1fa197e69..25aef19ec 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 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]) @@ -173,9 +174,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..47c5951cb 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-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 552e39772..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-2014 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 07f739df9..9c37bca9c 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. +# 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 cc690f8e2..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-2014 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 43156f450..e697174ed 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-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 85db95286..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-2014 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 839a04c17..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-2014 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 844ef6a8c..0aa040df3 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-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 3fac0ee09..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-2014 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 9b07b0709..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-2014 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 820dd4f77..fd46acc1b 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-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 3af23ec75..5f8505770 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-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 30f2e8e69..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-2014 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 @@ -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) @@ -62,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 ?= ^$$ @@ -155,6 +152,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 +194,7 @@ local-check := \ $(filter-out $(local-checks-to-skip), $(local-checks-available))) syntax-check: $(local-check) +endif # _sc_search_regexp # @@ -442,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 -l '\.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 && \ + @if $(VC_LIST_EXCEPT) | grep '\.c$$' > /dev/null; then \ + 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 :; \ @@ -469,7 +477,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 . && \ @@ -653,18 +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_TWOS_COMPLEMENT TYPE_ONES_COMPLEMENT \ - TYPE_SIGNED_MAGNITUDE 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: @@ -713,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 *\(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. @@ -1121,6 +1130,21 @@ fix_po_file_diag = \ 'you have changed the set of files with translatable diagnostics;\n\ apply the above patch\n' +# Generate a list of files in which to search for translatable strings. +perl_translatable_files_list_ = \ + -e 'foreach $$file (@ARGV) {' \ + -e ' \# Consider only file extensions with one or two letters' \ + -e ' $$file =~ /\...?$$/ or next;' \ + -e ' \# Ignore m4 and mk files' \ + -e ' $$file =~ /\.m[4k]$$/ and next;' \ + -e ' \# Ignore a .c or .h file with a corresponding .l or .y file' \ + -e ' $$file =~ /(.+)\.[ch]$$/ && (-e "$${1}.l" || -e "$${1}.y")' \ + -e ' and next;' \ + -e ' \# Skip unreadable files' \ + -e ' -r $$file or next;' \ + -e ' print "$$file ";' \ + -e '}' + # Verify that all source files using _() (more specifically, files that # match $(_gl_translatable_string_re)) are listed in po/POTFILES.in. po_file ?= $(srcdir)/po/POTFILES.in @@ -1130,21 +1154,8 @@ sc_po_check: @if test -f $(po_file); then \ grep -E -v '^(#|$$)' $(po_file) \ | grep -v '^src/false\.c$$' | sort > $@-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 \ @@ -1192,7 +1203,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) @@ -1282,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 @@ -1492,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 @@ -1597,7 +1610,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 +1643,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 +1653,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; } || : diff --git a/meta/build-env.in b/meta/build-env.in new file mode 100644 index 000000000..27e604366 --- /dev/null +++ b/meta/build-env.in @@ -0,0 +1,121 @@ +#!/bin/sh + +# Copyright (C) 2003, 2006, 2008-2012, 2016, 2017 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_srcdir}/prebuilt/@SCM_PREBUILT_BINARIES@:${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/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 dd3c212e8..89823e9c3 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 @@ -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}. # @@ -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 @@ -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 @@ -181,10 +213,15 @@ 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 +# 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 @@ -198,16 +235,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 + _guile_required_version=2.2 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=$_tmp$v + _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 @@ -224,8 +270,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]) @@ -237,20 +287,23 @@ 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 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) ]) diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index 567c6e243..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 Free Software Foundation +# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2015, 2017 Free Software Foundation # # This file is part of GUILE. # @@ -80,21 +80,17 @@ 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" - else - for d in "/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 - fi + for d in "/prebuilt/@SCM_PREBUILT_BINARIES@" "/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" ;; + esac + done export GUILE_LOAD_COMPILED_PATH # Don't look in installed dirs for guile modules diff --git a/module/Makefile.am b/module/Makefile.am index 8de78c221..044da6e7c 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -25,162 +25,148 @@ 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) \ - $(CPS2_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) \ - $(JS_IL_LANG_SOURCES) \ - $(JS_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 $(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" \ -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/inline.scm \ - language/tree-il/compile-cps2.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/compile-js.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 = \ - language/cps2.scm \ - language/cps2/cse.scm \ - language/cps2/compile-cps.scm \ - language/cps2/constructors.scm \ - language/cps2/contification.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/renumber.scm \ - language/cps2/optimize.scm \ - language/cps2/simplify.scm \ - language/cps2/self-references.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 - -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/atomic.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/fdes-finalizers.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/ports.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/sandbox.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/suspendable-ports.scm \ + ice-9/syncase.scm \ + ice-9/textual-ports.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/compile-js.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/handle-interrupts.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/specialize-numbers.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 \ @@ -188,9 +174,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 \ @@ -199,168 +184,35 @@ 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 - -JS_IL_LANG_SOURCES = \ + language/elisp/spec.scm \ + \ + language/javascript.scm \ + language/javascript/simplify.scm \ + language/javascript/spec.scm \ + \ language/js-il.scm \ language/js-il/inlining.scm \ language/js-il/compile-javascript.scm \ - language/js-il/spec.scm - -JS_LANG_SOURCES = \ - language/javascript.scm \ - language/javascript/simplify.scm \ - language/javascript/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/js-il/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 \ @@ -386,47 +238,120 @@ 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/syntax.scm \ + \ + system/xref.scm \ + \ sxml/apply-templates.scm \ sxml/fold.scm \ sxml/match.scm \ @@ -435,6 +360,7 @@ LIB_SOURCES = \ sxml/ssax.scm \ sxml/transform.scm \ sxml/xpath.scm \ + \ texinfo.scm \ texinfo/docbook.scm \ texinfo/html.scm \ @@ -442,9 +368,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 \ @@ -453,10 +378,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 \ @@ -474,3 +397,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 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* diff --git a/module/ice-9/atomic.scm b/module/ice-9/atomic.scm new file mode 100644 index 000000000..2a8af901d --- /dev/null +++ b/module/ice-9/atomic.scm @@ -0,0 +1,38 @@ +;; 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) + #:use-module ((language tree-il primitives) + :select (add-interesting-primitive!)) + #: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") + (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/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/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index a5b3422bc..a70cd11ef 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 @@ -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} @@ -149,53 +154,27 @@ a-cont ((@@ primitive pop-fluid)) (apply values vals)))) - - -;;; {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)) +(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} ;;; -;; 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) @@ -220,11 +199,11 @@ file with the given name already exists, the effect is unspecified." (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)) @@ -315,11 +294,13 @@ 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")) + +;; Temporary definition; replaced by a parameter later. +(define (allow-legacy-syntax-objects?) #f) ;;; {and-map and or-map} ;;; @@ -327,13 +308,10 @@ file with the given name already exists, the effect is unspecified." ;;; (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 @@ -341,12 +319,9 @@ file with the given name already exists, the effect is unspecified." 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 @@ -381,9 +356,8 @@ file with the given name already exists, the effect is unspecified." (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)) @@ -402,6 +376,13 @@ file with the given name already exists, the effect is unspecified." (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) @@ -739,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 @@ -792,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 @@ -893,12 +885,14 @@ 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) + ;; 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)))) (print-location frame port) (catch #t @@ -1193,11 +1187,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") @@ -1437,33 +1426,14 @@ 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))) - - -;;; 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")) +;; 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)) @@ -1481,140 +1451,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 @@ -1623,18 +1459,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} @@ -1756,95 +1580,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)) @@ -1958,8 +1696,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))))))) @@ -1972,10 +1709,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))) @@ -2259,15 +1996,15 @@ written into the port is returned." submodules submodule-binder public-interface - filename))) + filename + next-unique-id))) ;; 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) @@ -2283,7 +2020,7 @@ written into the port is returned." (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)) @@ -2296,15 +2033,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) @@ -2315,31 +2052,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)) @@ -2368,13 +2107,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) @@ -2389,21 +2125,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)))) @@ -2435,22 +2165,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)) @@ -2482,14 +2206,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) @@ -2497,14 +2217,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) @@ -2518,15 +2234,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 @@ -2540,13 +2253,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) @@ -2554,9 +2264,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)) @@ -2564,11 +2273,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)) @@ -2578,9 +2284,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) @@ -2622,12 +2327,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) @@ -2638,10 +2341,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) @@ -2649,10 +2351,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 @@ -2663,18 +2364,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 @@ -2686,12 +2383,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) @@ -2863,6 +2557,11 @@ written into the port is returned." (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 @@ -2891,6 +2590,11 @@ written into the port is returned." 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. ;; @@ -2921,6 +2625,21 @@ written into the port is returned." (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))) @@ -3029,40 +2748,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 '()) @@ -3071,6 +2756,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 @@ -3089,7 +2807,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 @@ -3119,77 +2836,71 @@ written into the port is returned." ;; sure to update "modules.c" as well. (define* (define-module* name - #:key filename pure version (duplicates '()) - (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))))) + (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. ;; (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))) - (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)))))) + (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)) + (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)))))) - (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)) @@ -3220,7 +2931,7 @@ written into the port is returned." #: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 @@ -3732,12 +3443,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)) @@ -3758,9 +3468,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)) @@ -3772,9 +3481,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)) @@ -3923,14 +3631,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))))) @@ -3956,8 +3673,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 @@ -4019,19 +3736,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. @@ -4039,19 +3760,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)) @@ -4070,28 +3791,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))))) @@ -4320,6 +4049,24 @@ 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))) + + + +;;; {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. ;;; @@ -4334,7 +4081,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) @@ -4346,11 +4093,16 @@ when none is available, reading FILE-NAME with READER." ids) (module-export! to ids)) - (steal-bindings! the-root-module (resolve-module '(system syntax)) - '(syntax-local-binding - syntax-module + (steal-bindings! the-root-module (resolve-module '(system syntax internal)) + '(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/ice-9/command-line.scm b/module/ice-9/command-line.scm index 0d2f3d601..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-2015 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 2014) + (copyright-year 2017) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) 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/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/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 9835c1230..2f41686ac 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -16,4 +16,78 @@ ;;;; (define-module (ice-9 deprecated) - #:export ()) + #:use-module ((ice-9 threads) #:prefix threads:)) + +(define-syntax-rule (define-deprecated var msg 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." + '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) + +(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 + 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) + +(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))) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 3b68f07ae..d21f59abd 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." @@ -495,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/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/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 @@ -89,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. @@ -152,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 @@ -252,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))) diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 1d12dd061..6b9ead532 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 @@ -80,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) @@ -211,7 +215,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? @@ -245,6 +249,52 @@ '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. 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. + (if (integer? digit-count) + (let ((number (* (expt 10 digit-count) + (- number (floor number))))) + (string-pad (integer->string (round (inexact->exact number))) + digit-count + #\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 ;; string with digit grouping and separators according to GROUPING (a list, @@ -335,13 +385,12 @@ 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)))) - (grouping (locale-monetary-digit-grouping locale)) + (int (integer->string (inexact->exact + (floor (abs amount))))) + (dec (decimal-part + (number-decimal-string (abs amount) + fraction-digits))) + (grouping (locale-monetary-grouping locale)) (separator (locale-monetary-thousands-separator locale))) (add-monetary-sign+currency amount @@ -369,6 +418,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." @@ -387,14 +437,11 @@ 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) + fraction-digits))) (grouping (locale-digit-grouping locale)) (separator (locale-thousands-separator locale))) @@ -414,4 +461,71 @@ 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 + (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)) + (cons 'locale-yes-regexp (locale-yes-regexp loc)) + (cons 'no-regexp (locale-no-regexp loc))))) ;;; i18n.scm ends here diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm new file mode 100644 index 000000000..8eee22988 --- /dev/null +++ b/module/ice-9/ports.scm @@ -0,0 +1,565 @@ +;;; 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") + + + +(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-module (ice-9 ports internal) + #: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 + 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 + port-clear-stream-start-for-bom-write + %port-encoding + specialize-port-encoding! + port-random-access? + port-decode-char + port-encode-char + port-encode-chars + port-read-buffering + port-poll + port-read-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)) +(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)) +(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-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 + (define binding (@@ (ice-9 ports) binding)) + ...))) + +(private-port-bindings port-read-buffer + port-write-buffer + port-auxiliary-write-buffer + port-line-buffered? + expand-port-read-buffer! + 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-char + port-encode-chars + port-random-access? + port-read-buffering + port-poll + port-read-wait-fd + port-write-wait-fd + put-char + put-string) + +;; And we're back. +(define-module (ice-9 ports)) + + + +;;; 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 (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/pretty-print.scm b/module/ice-9/pretty-print.scm index 007061f6e..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) + (define* (print x width #:key inner?) (cond ((<= width 0) (error "expected a positive width" width)) @@ -428,6 +429,29 @@ sub-expression, via the @var{breadth-first?} keyword argument." (display ")")) (else (display "#")))) + ((and (array? x) (not (string? x))) + (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) + (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 "#"))))) ((pair? x) (cond ((>= width (+ 4 ellipsis-width)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 6029f0565..d2c5a26d3 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,3304 +1,3397 @@ (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 () - (string-append "l-" (session-id) (symbol->string (gensym "-"))))) - (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) + (make-syntax 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) - (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) - (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 (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 + (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)) - 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 - 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 + '()))))) + ((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))))))))))))) + (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 - "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-1 transformer-environment) (t (lambda (k) (k e r w s rib mod)))) - (with-fluid* - t-1 - t - (lambda () - (rebuild-macro-output - (p (source-wrap e (anti-mark w) s mod)) - (gensym (string-append "m-" (session-id) "-"))))))))) - (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))) + '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 (make-syntax '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) + (list (make-syntax '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 + 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-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) - (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)) + (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)))))))))))))))) - (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 + (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 (make-syntax '... '((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 - (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*))) + (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)) - (syntax->datum rest) + #f (if (pair? kw) (cdr kw) kw) body - (cons v vars) + 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)))) - (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-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - 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))) - (gensym (string-append (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)) - (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-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - 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-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - 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-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - 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-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - 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))))) - (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))) + 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) - (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) + (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 () (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 (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 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 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 - '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))))))))))) - -(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))))))))) - -(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) + (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-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-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-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-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) - 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-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-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-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) - 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)))))))) + (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) - (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)))) + (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 (body binding) - (list '#(syntax-object let ((top)) (hygiene guile)) - (list binding) - body)) + (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) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))) + (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 + 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 (make-syntax '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 (make-syntax 'public '((top)) '(hygiene guile)) mod)))) 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)) + 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 + (list '_ + (vector 'free-id (make-syntax '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 (make-syntax 'private '((top)) '(hygiene guile)) mod)))) + tmp-1) (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))))) + (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 (make-syntax 'private '((top)) '(hygiene guile)) mod)))) + (values (remodulate exp mod) r w (source-annotation exp) mod))) 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) (list "value" tmp)) 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) (list "value" tmp)) 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) (list "value" tmp)) 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) (list "value" tmp)) 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 + (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 (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)))) + (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 - "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 + '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 (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 + #f + (build-simple-lambda #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)))) + (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 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 + (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 + (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 + (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) (cons "vector" t)) 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) (list "quote" tmp)) 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 tmp)) (list "list->vector" t))))))))))))))))) - (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) (cons '#(syntax-object list ((top)) (hygiene guile)) t)) - 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-1 t) - (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t)) - 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) - (cons '#(syntax-object append ((top)) (hygiene guile)) t)) - 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) - (cons '#(syntax-object vector ((top)) (hygiene guile)) t)) - 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 tmp)) - (list '#(syntax-object list->vector ((top)) (hygiene guile)) t)))) - 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-input-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 - (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 @@ -3329,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 c9c309ae1..5696c4642 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 @@ -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 () @@ -461,11 +466,31 @@ (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)) + (define (syntax-object? x) + (or (syntax? 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) + (make-syntax 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)) @@ -632,7 +657,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 +686,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 @@ -1087,9 +1112,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) @@ -2708,7 +2742,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) @@ -2734,7 +2770,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))) @@ -2785,7 +2821,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)) @@ -2849,7 +2885,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))))))) @@ -3183,7 +3220,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))))))) @@ -3203,10 +3240,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 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/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/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/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/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) diff --git a/module/ice-9/suspendable-ports.scm b/module/ice-9/suspendable-ports.scm new file mode 100644 index 000000000..a366c8b9c --- /dev/null +++ b/module/ice-9/suspendable-ports.scm @@ -0,0 +1,737 @@ +;;; 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 suspendable-ports) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 ports internal) + #:use-module (ice-9 match) + #:export (current-read-waiter + current-write-waiter + + install-suspendable-ports! + uninstall-suspendable-ports!)) + +(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) + (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 (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-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)) + (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)) +(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 cur buffered) + (and (<= (bytevector-length bom) buffered) + (let ((bv (port-buffer-bytevector 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) (io-mode 'text)) + (clear-stream-start-for-bom-read port io-mode) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf)) + (buffered (max (- (port-buffer-end buf) cur) 0))) + (cond + ((or (<= minimum-buffering buffered) (port-buffer-has-eof? buf)) + (values buf cur 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 0 buffered)) + (else + (let ((buffered (+ buffered read))) + (set-port-buffer-end! buf buffered) + (if (< buffered minimum-buffering) + (lp buffered) + (values buf 0 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)) + (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 cur buffered) + (kslow buf (port-buffer-bytevector buf) cur 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* (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 (max (- (port-buffer-end buf) cur) 0))) + (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 cur buffered) + (if (zero? buffered) + (begin + (set-port-buffer-has-eof?! buf #f) + (trim-and-return pos)) + (let ((pos (port-buffer-take! pos buf cur + (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 (put-u8 port byte) + (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)) + (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))) + (unless (<= 0 start (+ start count) (bytevector-length src)) + (error "invalid start/count" start count)) + (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 (max (- end cur) 0))) + (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. + ;; 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) + (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-next-cur/utf8 port buf cur first-byte) + (if (< first-byte #x80) + (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 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 buf (+ cur len)) + (decoding-error "peek-char" port)))) + (decode-utf8 bv cur buffering first-byte + (lambda (char len) + (values char buf (+ cur len))) + bad-utf8)))))) + +(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-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 cur buffered) + (cond + ((< buffered input-size) + ;; Buffer failed to fill; EOF, possibly premature. + (cond + ((zero? prev-input-size) + (values the-eof-object buf cur)) + ((eq? (port-conversion-strategy port) 'substitute) + (values #\xFFFD buf (+ cur prev-input-size))) + (else + (decoding-error "peek-char" port)))) + ((port-decode-char port (port-buffer-bytevector buf) + cur input-size) + => (lambda (char) + (values char buf (+ cur input-size)))) + (else + (lp input-size)))))))) + +(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-next-cur port)) + (lambda (char buf cur) + 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-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-position-column! pos (1+ (port-position-column pos)))) + (else + (case char + ((#\alarm) #t) ; No change. + ((#\backspace) + (let ((col (port-position-column pos))) + (when (> col 0) + (set-port-position-column! pos (1- col))))) + ((#\newline) + (set-port-position-line! pos (1+ (port-position-line pos))) + (set-port-position-column! pos 0)) + ((#\return) + (set-port-position-column! pos 0)) + ((#\tab) + (let ((col (port-position-column pos))) + (set-port-position-column! pos (- (+ col 8) (remainder col 8))))) + (else + (set-port-position-column! pos (1+ (port-position-column pos)))))))) + +(define* (read-char #:optional (port (current-input-port))) + (define (finish buf char) + (advance-port-position! (port-buffer-position buf) char) + char) + (define (slow-path) + (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))) + (case enc + ((UTF-8) + (decode-utf8 bv cur buffered u8 + (lambda (char len) + (set-port-buffer-cur! buf (+ cur len)) + (finish buf char)) + slow-path)) + ((ISO-8859-1) + (set-port-buffer-cur! buf (+ cur 1)) + (finish buf (integer->char u8))) + (else (slow-path))))) + (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* ((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) + ((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* (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* (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 accept + (let ((%accept (@ (guile) accept))) + (lambda* (port #:optional (flags 0)) + (let lp () + (or (%accept port flags) + (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 + accept connect) + ((ice-9 binary-ports) + get-u8 lookahead-u8 get-bytevector-n + put-u8 put-bytevector) + ((ice-9 textual-ports) + put-char put-string) + ((ice-9 rdelim) %read-line read-line read-delimited))) +(define (install-suspendable-ports!) + (unless saved-port-bindings + (set! saved-port-bindings (make-hash-table)) + (let ((suspendable-ports (resolve-module '(ice-9 suspendable-ports)))) + (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 suspendable-ports sym))) + syms)))) + port-bindings)))) + +(define (uninstall-suspendable-ports!) + (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))) diff --git a/module/ice-9/textual-ports.scm b/module/ice-9/textual-ports.scm new file mode 100644 index 000000000..ba30a8b1f --- /dev/null +++ b/module/ice-9/textual-ports.scm @@ -0,0 +1,70 @@ +;;;; 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 + unget-char + unget-string + 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 (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)) + +(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))))) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 9f9e1bf8e..65108d9f1 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -26,22 +26,49 @@ ;;; 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) + #: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 + ;; 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 + 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 +76,134 @@ 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")) + + + +(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 +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 () + (apply abort-to-prompt cancel-tag values)) + (lambda _ + (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 +@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)) + (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 () + (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 + ;; 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) + (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}." + (lock-mutex mutex 0)) + ;;; Macros first, so that the procedures expand correctly. @@ -58,6 +213,57 @@ (lambda () e0 e1 ...) %thread-handler)) +(define-syntax-rule (make-thread proc arg ...) + (call-with-new-thread + (lambda () (proc arg ...)) + %thread-handler)) + +(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 (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 () @@ -73,22 +279,6 @@ (lambda (v ...) b0 b1 ...))) -(define-syntax-rule (make-thread proc arg ...) - (call-with-new-thread - (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-syntax-rule (monitor first rest ...) - (with-mutex (make-mutex) - first rest ...)) - (define (par-mapper mapper cons) (lambda (proc . lists) (let loop ((lists lists)) @@ -190,29 +380,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/bytecode.scm b/module/language/bytecode.scm index 2ef98675a..c140b4bb3 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) + ((A32 AU32 AS32 AF32) 1) + ((B32 BF32 BS32 BU32) 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/language/cps.scm b/module/language/cps.scm index befa20f66..5d4826990 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -21,28 +21,75 @@ ;;; 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. +;;; 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. ;;; -;;; $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. +;;; 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 at which +;;; pass multiple named values, etc. $continue nodes also record the +;;; source location corresponding to the expression. ;;; -;;; 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. +;;; 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 @@ -51,51 +98,16 @@ ;;; 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). +;;; 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. @@ -104,7 +116,6 @@ (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) @@ -112,37 +123,22 @@ $arity make-$arity - ;; Terms. - $letk $continue - ;; Continuations. - $cont - - ;; Continuation bodies. $kreceive $kargs $kfun $ktail $kclause + ;; Terms. + $continue + ;; 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 + build-cont build-term build-exp + rewrite-cont rewrite-term rewrite-exp - ;; Misc. - parse-cps unparse-cps - make-global-cont-folder make-local-cont-folder - fold-conts fold-local-conts - visit-cont-successors)) + ;; External representation. + parse-cps unparse-cps)) ;; FIXME: Use SRFI-99, when Guile adds it. (define-syntax define-record-type* @@ -174,17 +170,15 @@ ;; 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 $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 cont alternate) +(define-cps-type $kclause arity kbody kalternate) + +;; Terms. +(define-cps-type $continue k src exp) ;; Expressions. (define-cps-type $const val) @@ -192,83 +186,53 @@ (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 $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) -;; 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 +(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-cps-term body))) + (make-$kargs (list name ...) syms (build-term body))) ((_ ($kargs (name ...) (sym ...) body)) - (make-$kargs (list name ...) (list sym ...) (build-cps-term body))) + (make-$kargs (list name ...) (list sym ...) (build-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))) + (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 cont alternate)) - (make-$kclause (build-arity arity) (build-cps-cont cont) - (build-cps-cont alternate))))) + ((_ ($kclause arity kbody kalternate)) + (make-$kclause (build-arity arity) kbody kalternate)))) -(define-syntax build-cps-cont - (syntax-rules (unquote) - ((_ (unquote exp)) exp) - ((_ (k cont)) (make-$cont k (build-cont-body cont))))) +(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-cps-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 body)) (make-$fun (build-cps-cont body))) + ((_ ($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)) @@ -283,50 +247,19 @@ ((_ ($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))) + ((_ ($branch kt exp)) (make-$branch kt (build-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) ...) +(define-syntax-rule (rewrite-cont x (pat cont) ...) (match x - (pat (build-cps-term body)) ...)) -(define-syntax-rule (rewrite-cps-cont x (pat body) ...) + (pat (build-cont cont)) ...)) +(define-syntax-rule (rewrite-term x (pat term) ...) (match x - (pat (build-cps-cont body)) ...)) -(define-syntax-rule (rewrite-cps-exp x (pat body) ...) + (pat (build-term term)) ...)) +(define-syntax-rule (rewrite-exp x (pat body) ...) (match x - (pat (build-cps-exp body)) ...)) + (pat (build-exp body)) ...)) (define (parse-cps exp) (define (src exp) @@ -334,121 +267,81 @@ (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))) + (build-cont ($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)))) + (build-cont ($kargs names syms ,(parse-cps body)))) + (('kfun meta self ktail kclause) + (build-cont ($kfun (src exp) meta self ktail kclause))) (('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)))) + (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-cps-term ($continue k (src exp) ,(parse-cps exp)))) + (build-term ($continue k (src exp) ,(parse-cps exp)))) + (('unspecified) + (build-exp ($const *unspecified*))) (('const exp) - (build-cps-exp ($const exp))) + (build-exp ($const exp))) (('prim name) - (build-cps-exp ($prim name))) - (('fun body) - (build-cps-exp ($fun ,(parse-cps body)))) + (build-exp ($prim name))) + (('fun kbody) + (build-exp ($fun kbody))) (('closure k nfree) - (build-cps-exp ($closure k nfree))) + (build-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)))) + (build-exp ($rec name sym (map parse-cps fun)))) (('call proc arg ...) - (build-cps-exp ($call proc arg))) + (build-exp ($call proc arg))) (('callk k proc arg ...) - (build-cps-exp ($callk k proc arg))) + (build-exp ($callk k proc arg))) (('primcall name arg ...) - (build-cps-exp ($primcall name arg))) + (build-exp ($primcall name arg))) (('branch k exp) - (build-cps-exp ($branch k ,(parse-cps exp)))) + (build-exp ($branch k ,(parse-cps exp)))) (('values arg ...) - (build-cps-exp ($values arg))) + (build-exp ($values arg))) (('prompt escape? tag handler) - (build-cps-exp ($prompt escape? tag handler))) + (build-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 ($ $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))) + (($ $kfun src meta self ktail kclause) + `(kfun ,meta ,self ,ktail ,kclause)) (($ $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)) '()))) + (($ $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) - `(const ,val)) + (if (unspecified? val) + '(unspecified) + `(const ,val))) (($ $prim name) `(prim ,name)) - (($ $fun body) - `(fun ,(unparse-cps body))) + (($ $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))) - (($ $program conts) - `(program ,(map unparse-cps conts))) (($ $call proc args) `(call ,proc ,@args)) (($ $callk k proc args) @@ -463,158 +356,3 @@ `(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/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 49ff30f93..2fe4d8030 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -33,533 +33,816 @@ #: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 (srfi srfi-11) #:use-module (language cps) - #:use-module (language cps dfg) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) #:export (convert-closures)) -;; free := var ... +(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 (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) +(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 - (($ $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))) + (($ $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 - ((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 '())))) + (($ $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))) - (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)))) + (intset-fold rewrite-cont (intmap-ref functions kfun) cps)) -(define (prune-free-vars free-vars named-funs well-known var-aliases) + ;; 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) - (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))) + (intset-ref well-known label)) -(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) + (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 - ((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)))) + ((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))) + (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)))))) - (define (convert-free-vars vars k) + (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 - (() (k '())) + (() + (with-cps cps + ($ (k '())))) ((var . vars) - (convert-free-var var - (lambda (var) - (convert-free-vars vars - (lambda (vars) - (k (cons 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 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 _ _) + (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. - (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)))))) + (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 . _) - (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))))))))) + (#(#t nfree) + (unless (> nfree 2) + (error "unexpected well-known nullary, unary, or binary closure")) + (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 src var known? closure-free body) + (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 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) +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 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))))))))) + (#(#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. (_ - (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)))))) + (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) + (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 'free-set! + (var idx v))))))))))))))))))) - ;; 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 (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))))))) - (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) + ;; 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 - (($ $letk conts body) - (build-cps-term - ($letk ,(filter-map maybe-visit-cont conts) ,(visit-term body)))) - (($ $continue k src (or ($ $const) ($ $prim))) - term) + (with-cps cps + 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))))))))))) + (($ $continue k src ($ $fun kfun)) + (with-cps cps + ($ (make-single-closure k src kfun)))) ;; 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 ($ $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 (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)))))))) + (match (intmap-ref bound->label proc (lambda (_) #f)) (#f - (convert-free-vars (cons proc args) - (match-lambda - ((proc . args) - (build-cps-term - ($continue k src - ($call proc args))))))))) + (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-free-vars args - (lambda (args) - (build-cps-term - ($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-free-vars args - (lambda (args) - (build-cps-term - ($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-free-var arg - (lambda (arg) - (build-cps-term - ($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-free-vars args - (lambda (args) - (build-cps-term - ($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-free-var tag - (lambda (tag) - (build-cps-term - ($continue k src - ($prompt escape? tag handler)))))))) - (visit-cont (build-cps-cont (label ,fun))))) + (convert-arg cps tag + (lambda (cps tag) + (with-cps cps + (build-term + ($continue k src + ($prompt escape? tag handler))))))))) -(define (convert-closures fun) - "Convert free reference in @var{exp} to primcalls to @code{free-ref}, + (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 ((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))))))))) + (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 index 86a3db733..c283eb614 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -27,88 +27,72 @@ #: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 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) - #: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 (language cps split-rec) + #:use-module (language cps intmap) + #:use-module (language cps intset) #: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))) +(define (intmap-for-each f map) + (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) - ;; 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. +(define (intmap-select map set) + (persistent-intmap + (intset-fold + (lambda (k out) + (intmap-add! out k (intmap-ref map k))) + set + empty-intmap))) - ;; 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!. +;; 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))) - (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) +(define (compile-function cps asm) + (let* ((allocation (allocate-slots cps)) + (forwarding-labels (compute-forwarding-labels cps allocation)) + (frame-size (lookup-nlocals allocation))) + (define (forward-label k) + (intmap-ref forwarding-labels k (lambda (k) k))) - ;; 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 (elide-cont? label) + (match (intmap-ref forwarding-labels label (lambda (_) #f)) + (#f #f) + (target (not (eqv? label target))))) - exp) - -(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)) @@ -118,110 +102,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))) - - (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)))))) + (emit-mov asm (from-sp dst) (from-sp src)))) (define (compile-tail label exp) ;; There are only three kinds of expressions in tail position: @@ -229,215 +115,308 @@ (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)) - (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))) + ((src . dst) (emit-mov asm (from-sp dst) (from-sp 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))) + ((src . dst) (emit-mov asm (from-sp dst) (from-sp 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))))) + (emit-return-values asm (1+ (length args)))))) - (define (compile-value label exp dst nlocals) + (define (compile-value label exp dst) (match exp (($ $values (arg)) - (or (maybe-load-constant dst arg) - (maybe-mov dst (slot 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 'current-thread) + (emit-current-thread 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 'define! (sym)) + (emit-define! asm (from-sp dst) (from-sp (slot sym)))) (($ $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 '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)) + (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 '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 dst (constant 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 '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 '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)) + (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)) - (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 '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))) - (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 nlocals) + (define (compile-effect label exp k) (match exp (($ $values ()) #f) (($ $prompt escape? tag handler) - (match (lookup-cont handler dfg) + (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 handler allocation))) - (emit-prompt asm (slot tag) escape? proc-slot receive-args) + (proc-slot (lookup-call-proc-slot label allocation))) + (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)) (emit-receive-values asm proc-slot (->bool rest) nreq)) (when (and rest - (match (lookup-cont khandler-body dfg) + (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))) + ((src . dst) (emit-fmov asm dst src))) (lookup-parallel-moves handler allocation)) - (emit-reset-frame asm nlocals) - (emit-br asm khandler-body))))) + (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 '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 (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))) - (($ $primcall 'define! (sym value)) - (emit-define! asm (slot sym) (slot value))) + (emit-set-cdr! asm (from-sp (slot pair)) (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 '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 (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)))) + (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 ()) + (emit-handle-interrupts 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)))) + ((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) + (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)) + (op asm (from-sp (slot sym)) #t kf)) + ((eq? kf next-label) + (op asm (from-sp (slot sym)) #f kt)) (else - (op asm (slot sym) #f kt) - (unless (eq? kf next-label) - (emit-br asm kf))))) + (let ((invert? (not (prefer-true?)))) + (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 (from-sp (slot a)) (from-sp (slot b)) #f kt)) (else - (op asm (slot a) (slot b) #f kt) - (unless (eq? kf next-label) - (emit-br asm kf))))) + (let ((invert? (not (prefer-true?)))) + (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)) - (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))))) + (($ $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)) @@ -455,26 +434,38 @@ ;; 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)))) + (($ $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 '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)) + (($ $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 nlocals) + (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))) + ((src . dst) (emit-mov asm (from-sp dst) (from-sp 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)) + (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) @@ -484,16 +475,16 @@ ;; The usual case: one required live return value, ignoring ;; any additional values. => (lambda (dst) - (emit-receive asm dst proc-slot nlocals))) + (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))) + ((src . dst) (emit-fmov asm dst src))) (lookup-parallel-moves k allocation)) - (emit-reset-frame asm nlocals))))) + (emit-reset-frame asm frame-size))))) (match exp (($ $call proc args) (do-call proc args @@ -504,28 +495,115 @@ (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 (skip-elided-conts label) + (if (elide-cont? label) + (skip-elided-conts (1+ label)) + label)) -(define (compile-bytecode exp env opts) - ;; See comment in `optimize' about the use of set!. + (define (compile-expression label k exp) + (let* ((forwarded-k (forward-label k)) + (fallthrough? (= forwarded-k (skip-elided-conts (1+ label))))) + (define (maybe-emit-jump) + (unless fallthrough? + (emit-br asm forwarded-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 (forward-label kt) forwarded-k + (skip-elided-conts (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)))) + (let* ((kargs (forward-label kargs)) + (fallthrough? (and fallthrough? + (= kargs (skip-elided-conts (1+ k)))))) + (unless fallthrough? + (emit-br asm kargs))))))) - ;; 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)) + (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) + (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) + ;; 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) + (let ((slot (maybe-slot var))) + (when slot + (let ((repr (lookup-representation var allocation))) + (emit-definition asm name slot repr))))) + names vars) + (when src + (emit-source asm src)) + (unless (elide-cont? label) + (compile-expression label k exp))) + (($ $kreceive arity kargs) + (emit-label asm label)) + (($ $ktail) + (emit-end-arity asm) + (emit-end-program asm)))) - (set! exp (convert-closures exp)) - ;; first-order optimization should go here - (set! exp (reify-primitives exp)) - (set! exp (renumber exp)) - (let* ((asm (make-assembler))) - (match exp - (($ $program funs) - (for-each (lambda (fun) (compile-fun fun asm)) - funs))) + (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) + ;; 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)) + (set! exp (reify-primitives exp)) + (set! exp (add-handle-interrupts 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 index bbe779d27..170f0f17d 100644 --- a/module/language/cps/constructors.scm +++ b/module/language/cps/constructors.scm @@ -25,80 +25,82 @@ (define-module (language cps constructors) #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #: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-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))))) +(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)))) - (visit-cont fun)) +(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)) + (letv u64) + (letk kunbox ($kargs ('idx) (u64) + ($continue knext src + ($primcall 'vector-set! (vec u64 arg))))) + ($ (with-cps-constants ((idx n)) + (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)) + (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 (inline-constructors fun) - (with-fresh-name-state fun - (inline-constructors* fun))) +(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 index 1f702310a..f5727f842 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -30,385 +30,419 @@ (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 (srfi srfi-11) + #:use-module ((srfi srfi-1) #:select (fold)) #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps primitives) - #:use-module (language bytecode) + #:use-module (language cps renumber) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) #: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 (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 (lookup-return-cont k) - (match (assq-ref cont-substs k) - (#f k) - (k (lookup-return-cont k)))) +(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))) - ;; 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 (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)) - (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 '()))) +;; 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 (contify-fun term-k sym self tail arities bodies) - (contify-funs term-k - (list sym) (list self) (list tail) - (list arities) (list bodies))) +(define (arity-matches? arity nargs) + (match arity + (($ $arity req () #f () aok?) + (= nargs (length req))) + (_ + #f))) - ;; 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) +(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)) + (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 - (($ $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) + (($ $kargs _ _ ($ $continue _ _ 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))))) + ((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec)) + functions) + (($ $values args) + (exclude-vars functions args)) + (($ $call proc args) + (let ((functions (exclude-vars functions args))) + ;; 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)))) + ;; + ;; 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)) + (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))) - (visit-cont fun) - (values call-substs cont-substs cont-splices))) +(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 (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 (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 (assq-ref cont-substs k) + (match (return-subst 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)) + (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 + (($ $call) exp) + ;; A primcall that can continue to $ktail can also + ;; continue to $kreceive. + (($ $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)))) -(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)))))) + ;; 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 index c8a57ca0b..e37e8d487 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -25,282 +25,242 @@ (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 dfg) + #:use-module (language cps utils) #:use-module (language cps effects-analysis) - #:use-module (language cps renumber) + #:use-module (language cps intmap) #: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))))))) +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) - (($ $kreceive arity k) (list k)) +(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 ...))))))) - (($ $kclause arity ($ $cont kbody)) (list kbody)) +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) - (($ $kfun src meta self tail clause) - (let lp ((clause clause)) - (match clause - (($ $cont kclause ($ $kclause _ _ alt)) - (cons kclause (lp alt))) - (#f '())))) +(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)))))) - (($ $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)) + (define (clobber label in) + (let ((fx (intmap-ref effects label))) (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))) + ((not (causes-effect? fx &write)) + ;; Fast-path if this expression clobbers nothing. + in) (else - (values avail effects)))))) + ;; 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 (compute-truthy-expressions dfg min-label label-count) + (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) "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))) +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! 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))) + (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)))))) - (vector-set! boolv 0 empty-intset) + (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))) - (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))))) + (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))))) + + (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 + (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 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-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-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)))) +(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))))) -;; 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 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-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) + (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 (map subst-var args))) + (cons* 'primcall name (subst-vars var-substs args))) (($ $branch _ ($ $primcall name args)) - (cons* 'primcall name (map subst-var args))) + (cons* 'primcall name (subst-vars var-substs 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-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 @@ -309,14 +269,14 @@ could be that both true and false proofs are available." (('primcall 'box val) (match defs ((box) - (add-def! `(primcall box-ref ,(subst-var box)) val)))) + (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-var pair)) car) - (add-def! `(primcall cdr ,(subst-var pair)) cdr)))) + (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) @@ -324,7 +284,7 @@ could be that both true and false proofs are available." (('primcall (or 'make-vector 'make-vector/immediate) len fill) (match defs ((vec) - (add-def! `(primcall vector-length ,(subst-var vec)) len)))) + (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) @@ -332,214 +292,167 @@ could be that both true and false proofs are available." (('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)) + (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)) + (('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)))) + (('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) + (add-def! `(primcall scm->u64/truncate ,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)))) - ;; 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)))) + (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 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))) + ;; 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))) - (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))))))) + (intset-fold visit-fun + (intmap-keys (compute-reachable-functions conts kfun)) + empty-intmap + empty-intmap)) -(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 (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) - ;; 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))) + (intmap-ref var-substs var (lambda (var) 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-exp exp) + (rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,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-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 + (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) - (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)))))))) + (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 (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))))) +(define (eliminate-common-subexpressions conts) + (call-with-values + (lambda () + (let ((effects (synthesize-definition-effects (compute-effects conts)))) + (compute-equivalent-subexpressions conts 0 effects))) + (lambda (equiv-labels var-substs) + (let ((truthy-labels (compute-truthy-expressions conts 0))) + (apply-cse conts equiv-labels var-substs truthy-labels))))) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 34ffc3a47..52bd70898 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -18,346 +18,346 @@ ;;; 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. +;;; 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 (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) + #: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-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 (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 (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 (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 (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-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 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 (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 (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)) + (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 - (($ $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)) + (($ $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 (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))))))) + (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/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/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 7a49f869f..4eff0d261 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -41,11 +41,12 @@ (define-module (language cps effects-analysis) #:use-module (language cps) - #:use-module (language cps dfg) + #:use-module (language cps utils) + #:use-module (language cps intmap) #:use-module (ice-9 match) #:export (expression-effects compute-effects - synthesize-definition-effects! + synthesize-definition-effects &allocation &type-check @@ -61,7 +62,9 @@ &module &struct &string + &thread &bytevector + &closure &object &field @@ -168,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. @@ -179,7 +185,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)) @@ -227,32 +236,26 @@ is or might be a read or a write to the same location as A." (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-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* dfg +(define-syntax-rule (define-primitive-effects* constants ((name . args) effects ...) ...) (begin (hashq-set! *primitive-effects* 'name (case-lambda* - ((dfg . args) (logior effects ...)) + ((constants . args) (logior effects ...)) (_ &all-effects))) ...)) (define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...) - (define-primitive-effects* dfg ((name . args) effects ...) ...)) + (define-primitive-effects* constants ((name . args) effects ...) ...)) ;; Miscellaneous. (define-primitive-effects @@ -284,7 +287,15 @@ 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 +;; thread. +(define-primitive-effects + ((current-thread) (&read-object &thread))) ;; Prompts. (define-primitive-effects @@ -310,38 +321,38 @@ is or might be a read or a write to the same location as A." ((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 +(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 n init) (&allocate &vector)) ((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-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 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 +(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 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-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. @@ -352,9 +363,22 @@ 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 and integers. +(define-primitive-effects + ((scm->f64 _) &type-check) + ((load-f64 _)) + ((f64->scm _)) + ((scm->u64 _) &type-check) + ((scm->u64/truncate _) &type-check) + ((load-u64 _)) + ((u64->scm _)) + ((scm->s64 _) &type-check) + ((load-s64 _)) + ((s64->scm _))) + ;; 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) @@ -378,6 +402,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)) @@ -385,7 +420,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 @@ -394,13 +429,38 @@ 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->= . _)) + ((u64-<-scm . _) &type-check) + ((u64-<=-scm . _) &type-check) + ((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) ((mul . _) &type-check) ((sub . _) &type-check) + ((sub/immediate . _) &type-check) ((div . _) &type-check) - ((sub1 . _) &type-check) - ((add1 . _) &type-check) + ((fadd . _)) + ((fsub . _)) + ((fmul . _)) + ((fdiv . _)) + ((uadd . _)) + ((usub . _)) + ((umul . _)) + ((uadd/immediate . _)) + ((usub/immediate . _)) + ((umul/immediate . _)) ((quo . _) &type-check) ((rem . _) &type-check) ((mod . _) &type-check) @@ -418,7 +478,16 @@ 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) + ((ulogand . _)) + ((ulogior . _)) + ((ulogxor . _)) + ((ulogsub . _)) + ((ursh . _)) + ((ulsh . _)) + ((ursh/immediate . _)) + ((ulsh/immediate . _)) ((logtest a b) &type-check) ((logbit? a b) &type-check) ((sqrt _) &type-check) @@ -426,56 +495,55 @@ is or might be a read or a write to the same location as A." ;; Characters. (define-primitive-effects - ((char=? . _) &type-check) - ((char>? . _) &type-check) ((integer->char _) &type-check) ((char->integer _) &type-check)) -(define (primitive-effects dfg name args) +;; 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 - (apply proc dfg args) + (apply proc constants args) &all-effects))) -(define (expression-effects exp dfg) +(define (expression-effects exp constants) (match exp ((or ($ $const) ($ $prim) ($ $values)) &no-effects) - ((or ($ $fun) ($ $rec)) + (($ $closure _ 0) + &no-effects) + ((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) - (expression-effects exp dfg)) + (expression-effects exp constants)) (($ $primcall name args) - (primitive-effects dfg name args)))) + (primitive-effects constants 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)) +(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' @@ -487,13 +555,9 @@ is or might be a read or a write to the same location as A." ;; 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)))))) +(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 index dadbd403a..81ccfc200 100644 --- a/module/language/cps/elide-values.scm +++ b/module/language/cps/elide-values.scm @@ -30,80 +30,59 @@ (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) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) #: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))))) +(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)))))) - (visit-cont fun)) - -(define (elide-values fun) - (with-fresh-name-state fun - (let ((conts (build-cont-table fun))) - (elide-values* fun conts)))) +(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/handle-interrupts.scm b/module/language/cps/handle-interrupts.scm new file mode 100644 index 000000000..55d25f28a --- /dev/null +++ b/module/language/cps/handle-interrupts.scm @@ -0,0 +1,69 @@ +;;; 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 intset) + #:use-module (language cps renumber) + #:export (add-handle-interrupts)) + +(define (compute-safepoints cps) + (define (visit-cont label cont safepoints) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (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 (intset-fold add-safepoint safepoints cps))))) diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm index ba9d1c0bf..3a4f51776 100644 --- a/module/language/cps/intmap.scm +++ b/module/language/cps/intmap.scm @@ -33,8 +33,8 @@ (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) + #: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 87956c525..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? @@ -40,7 +41,9 @@ intset-remove intset-ref intset-next + intset-prev intset-fold + intset-fold-right intset-union intset-intersect intset-subtract @@ -100,7 +103,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 @@ -116,9 +118,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) @@ -135,7 +141,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)) @@ -391,31 +397,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 +465,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 @@ -508,6 +554,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. @@ -529,10 +577,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)) @@ -644,10 +692,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)) @@ -719,7 +767,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) @@ -764,13 +814,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)) 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 new file mode 100644 index 000000000..b1cbc89a7 --- /dev/null +++ b/module/language/cps/optimize.scm @@ -0,0 +1,133 @@ +;;; 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 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 specialize-numbers) + #:use-module (language cps type-fold) + #:use-module (language cps verify) + #:export (optimize-higher-order-cps + optimize-first-order-cps + cps-default-optimization-options)) + +(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)) + ... + (maybe-verify program))) + +;; Passes that are needed: +;; +;; * Abort contification: turning abort primcalls into continuation +;; calls, and eliding prompts if possible. +;; +(define-optimizer optimize-higher-order-cps + ;; 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) + (contify #:contify? #t) + (inline-constructors #:inline-constructors? #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 + (specialize-numbers #:specialize-numbers? #t) + (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)) + +(define (cps-default-optimization-options) + (list ;; #:split-rec? #t + #:simplify? #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 + #:specialize-numbers? #t + #:licm? #t + #:rotate-loops? #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)))) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 5f7f474f8..a3e6e38e6 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -34,13 +34,15 @@ )) (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) (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) @@ -82,13 +84,27 @@ (char? . (1 . 1)) (eq? . (1 . 2)) (eqv? . (1 . 2)) - (equal? . (1 . 2)) (= . (1 . 2)) (< . (1 . 2)) (> . (1 . 2)) (<= . (1 . 2)) (>= . (1 . 2)) - (logtest . (1 . 2)))) + (u64-= . (1 . 2)) + (u64-< . (1 . 2)) + (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)) + (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/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm index c224f4531..7c10319e8 100644 --- a/module/language/cps/prune-bailouts.scm +++ b/module/language/cps/prune-bailouts.scm @@ -25,77 +25,62 @@ (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 (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 (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 (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-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* 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))) +(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 index 4839b71f7..1970d1bc3 100644 --- a/module/language/cps/prune-top-level-scopes.scm +++ b/module/language/cps/prune-top-level-scopes.scm @@ -25,90 +25,39 @@ (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-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) +(define (compute-used-scopes conts constants) + (persistent-intset + (intmap-fold + (lambda (label cont used-scopes) (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)))) + (($ $kargs _ _ + ($ $continue k src + ($ $primcall 'cached-toplevel-box (scope name bound?)))) + (intset-add! used-scopes (intmap-ref constants scope))) + (_ + used-scopes))) + conts + empty-intset))) - (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))) +(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 index 286fd7c41..60be330b2 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -27,22 +27,25 @@ (define-module (language cps reify-primitives) #:use-module (ice-9 match) #:use-module (language cps) - #:use-module (language cps dfg) + #: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 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 (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 @@ -72,107 +75,105 @@ 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)) + ((current-thread) '(ice-9 threads)) ((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 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 (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 idx k src) - (let-fresh () (idx-var) - (build-cps-term - ($letconst (('idx idx-var idx)) - ($continue k src - ($primcall 'builtin-ref (idx-var))))))) +(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 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-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/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))))) +;; 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)))) - (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 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))) -(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))))))) + (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 index 8a1c7a0f2..8bab8634d 100644 --- a/module/language/cps/renumber.scm +++ b/module/language/cps/renumber.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2014, 2015 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 @@ -27,317 +27,191 @@ (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-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)))) +(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)))))))) - (let ((cont (vector-ref conts k))) - ;; Clear the cont table entry to mark this continuation as - ;; visited. - (vector-set! conts k #f) +(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)))) - (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)))) +(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/rotate-loops.scm b/module/language/cps/rotate-loops.scm new file mode 100644 index 000000000..09c133227 --- /dev/null +++ b/module/language/cps/rotate-loops.scm @@ -0,0 +1,239 @@ +;;; 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 (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (rotate-loops)) + +(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 (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)) + (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)) + (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) + (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)))))) + +(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) + (trivial-intset + (intset-subtract (intmap-ref succs entry) scc)) + (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 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))) + (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)))) diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm index 45e2389ff..cbdaaa107 100644 --- a/module/language/cps/self-references.scm +++ b/module/language/cps/self-references.scm @@ -18,62 +18,62 @@ ;;; Commentary: ;;; -;;; A pass that prunes successors of expressions that bail out. +;;; 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 fun #:optional (env '())) +(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap)) (define (subst var) - (or (assq-ref env var) var)) + (intmap-ref env var (lambda (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 (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-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)) + (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 index 10e9d0aa2..280e2573d 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -29,300 +29,246 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps renumber) + #:use-module (language cps utils) + #:use-module (language cps intset) + #:use-module (language cps intmap) #: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 (intset-maybe-add! set k add?) + (if add? (intset-add! set k) set)) -(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 (intset-add*! set k*) + (fold1 (lambda (k set) (intset-add! set k)) k* set)) -(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 (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 (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))) +(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))) -;; 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 (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)))) - (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)))) +;;; 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 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)))) (_ - ($continue k src ,exp)))) + eta))) + (intset-fold visit-cont body eta)) + (persistent-intset + (intmap-fold visit-fun + (compute-reachable-functions conts kfun) + empty-intset))) - (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 (eta-reduce 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 + ;; 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 ($ $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))) + (($ $kreceive ($ $arity req () rest () #f) k) + ($kreceive req rest (subst k))) + (($ $kclause arity body alt) + ($kclause ,arity (subst body) alt)) + (_ ,cont)))) + conts))) - (define (visit-dom-conts* labels) - (match labels - (() '()) - ((label . labels) - (append (visit-dom-conts label) - (visit-dom-conts* labels))))) +(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)))) - (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)))))))) +(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))) - (visit-fun-cont fun))) +(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 (simplify fun) - ;; Renumbering prunes continuations that are made unreachable by - ;; eta/beta reductions. - (redominate (renumber (eta-reduce (beta-reduce fun))))) +(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 index d8cbd15ba..6813a511f 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -1,4 +1,4 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) +;; Continuation-passing style (CPS) intermediate language (IL) ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. @@ -26,91 +26,439 @@ #: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 dfg) + #:use-module (language cps utils) + #:use-module (language cps intmap) #:use-module (language cps intset) #:export (allocate-slots lookup-slot lookup-maybe-slot + lookup-representation lookup-constant-value lookup-maybe-constant-value lookup-nlocals lookup-call-proc-slot lookup-parallel-moves - lookup-dead-slot-map)) + lookup-slot-map)) (define-record-type $allocation - (make-allocation dfa slots - has-constv constant-values - call-allocations - nlocals) + (make-allocation slots representations constant-values call-allocs + shuffles frame-size) 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. + ;; A map of VAR to slot allocation. A slot allocation is an integer, + ;; if the variable has been assigned a slot. ;; - (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. + ;; A map of VAR to representation. A representation is 'scm, 'f64, + ;; 'u64, or 's64. + ;; + (representations allocation-representations) + + ;; A map of VAR to constant value, for variables with constant values. ;; - (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 map of LABEL to /call allocs/, for expressions that continue to + ;; $kreceive continuations: non-tail calls and $prompt expressions. ;; - ;; 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. + ;; 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. ;; - ;; $kreceive continuations record a proc slot and a set of return moves - ;; to adapt multiple values from the stack to local variables. + ;; 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. ;; - ;; 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. + (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. A dead slot map is a bitfield, as an integer. + ;; variable. ;; - (call-allocations allocation-call-allocations) + (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. ;; - (nlocals allocation-nlocals)) + (frame-size allocation-frame-size)) -(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-record-type $call-alloc + (make-call-alloc proc-slot slot-map) + call-alloc? + (proc-slot call-alloc-proc-slot) + (slot-map call-alloc-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 (lookup-representation var allocation) + (intmap-ref (allocation-representations 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-slot-map k allocation) + (or (call-alloc-slot-map (lookup-call-alloc k allocation)) + (error "Call has no slot map" k))) + +(define (lookup-nlocals allocation) + (allocation-frame-size allocation)) + +(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 (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) + (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. + (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 k _ ($ $prompt escape? tag handler))) + (visit-prompt k 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)) + (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) + 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 (or 'load-f64 'load-u64 'load-s64) (val)) + 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 (or 'add/immediate 'sub/immediate + 'uadd/immediate 'usub/immediate 'umul/immediate + 'ursh/immediate 'ulsh/immediate) + (x y)) + (defs+ 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))) + (($ $kargs _ _ ($ $continue k _($ $values args))) + (match (intmap-ref cps k) + (($ $ktail) (list->intset args)) + (_ #f))) + (_ #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)) + (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 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) + (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. @@ -131,49 +479,10 @@ 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 (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 @@ -224,55 +533,323 @@ are comparable with eqv?. A tmp slot may be used." 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 (compute-shuffles cps slots call-allocs live-in) + (define (add-live-slot slot live-slots) + (logior live-slots (ash 1 slot))) -(define (dead-after-use? k-idx v-idx dfa) - (not (intset-ref (dfa-k-out dfa k-idx) v-idx))) + (define (get-cont label) + (intmap-ref cps label)) -(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 (get-slot var) + (intmap-ref slots var (lambda (_) #f))) - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) + (define (get-slots vars) + (let lp ((vars vars)) + (match vars + ((var . vars) (cons (get-slot var) (lp vars))) + (_ '())))) - (define (bump-nlocals! nlocals*) - (when (< nlocals nlocals*) - (set! nlocals nlocals*))) + (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. + (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-size 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 size) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (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) + (shuffle-size (get-shuffles label) size)) + (_ size))) + + (intmap-fold measure-cont cps minimum-frame-size)) + +(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) + (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) + (if (and hint (not (logbit? hint live-slots))) + hint + (find-first-zero live-slots))) + +(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 (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))) + (($ $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 'scm->u64/truncate 'load-u64 + 'char->integer + 'bv-length 'vector-length 'string-length + 'uadd 'usub 'umul + '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)) + (intmap-add representations var 'u64)) + (($ $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)))) + (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)) + ((lazy) (compute-lazy-vars cps live-in live-out defs + needs-slot))) (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))) @@ -281,422 +858,184 @@ are comparable with eqv?. A tmp slot may be used." 0 (1- (find-first-trailing-zero live-slots)))) - (define (recompute-live-slots k nargs) - (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 (get-cont label) + (intmap-ref cps label)) - (define* (allocate! var-idx hint live) + (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 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) + ((or 'u64 'f64 's64) 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 (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) + ((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))) - (bump-nlocals! (1+ slot)) - (vector-set! slots var-idx slot) - (add-live-slot slot live))))) + (values (intmap-add! slots var 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 (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 (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)) + (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)))))))))) - ;; 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) + ;; 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-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)))) + (let ((tail-slots (integers 0 (length args)))) + (values (allocate* args tail-slots slots pre-live) + call-allocs))) (($ $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)))) - - (_ - (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)))))) - - (define (allocate-values label k uses pre-live post-live) - (match (lookup-cont k dfg) + (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))))) + ((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)))))) + + (define (allocate-values label k args slots call-allocs) + (match (get-cont k) (($ $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 (_) (_)) + (values slots call-allocs)) + (($ $kargs (_) (dst)) ;; 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 + ;; 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 uses it. Because we don't know the + ;; 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 (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)))))) + (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 nargs) - (match (lookup-cont handler dfg) + (define (allocate-prompt label k handler slots call-allocs) + (match (get-cont handler) (($ $kreceive arity kargs) - (let* ((handler-live (recompute-live-slots handler nargs)) - (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)))))) + (let*-values + (((handler-live) (compute-live-in-slots slots handler)) + ((proc-slot) (compute-prompt-handler-proc-slot 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))) + ((slots result-live) (allocate* result-vars value-slots + slots handler-live))) + (values slots + (intmap-add! call-allocs label + (make-call-alloc proc-slot slot-map))))))) - (define (allocate-defs! n live) - (fold (cut allocate! <> #f <>) live (vector-ref defv n))) + (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)))) - ;; 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 (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 nargs) - 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 nargs)))) - (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 nargs)) - (_ #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) - nargs - (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))) + (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-size (compute-frame-size cps slots calls shuffles))) + (make-allocation slots representations constants calls + shuffles frame-size)))))) diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm index ec73528ad..26d0c9425 100644 --- a/module/language/cps/spec.scm +++ b/module/language/cps/spec.scm @@ -1,17 +1,17 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013 Free Software Foundation, Inc. +;; 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 @@ -19,20 +19,34 @@ ;;; 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) #:use-module (language cps compile-js) #: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) (js-il . ,compile-js)) #:for-humans? #f diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm new file mode 100644 index 000000000..d5587037b --- /dev/null +++ b/module/language/cps/specialize-numbers.scm @@ -0,0 +1,724 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; 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 +;;;; 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. +;;; +;;; 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 (srfi srfi-11) + #: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) + #: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-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) + ('logand 'ulogand) + ('logior 'ulogior) + ('logxor 'ulogxor) + ('logsub 'ulogsub) + ('rsh 'ursh) + ('lsh 'ulsh)))) + (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 unbox-b (b))))) + (build-term + ($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 + (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-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-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))) + +(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)) (visited empty-intset) + (out empty-intmap)) + (match (intset-prev worklist) + (#f out) + (label + (let ((worklist (intset-remove worklist label)) + (visited* (intset-add visited label))) + (define (continue 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) + (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) + (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) + (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 sigbits) + (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)) + (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)))))) + (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))) + (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)))) + (match (intmap-ref cps k) + (($ $kargs (_) (result)) + (call-with-values (lambda () + (lookup-post-type types label result 0)) + (lambda (type min max) + (values + (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) + (or (<= 0 min max #xffffffffffffffff) + (only-u64-bits-used? result)) + (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 + sigbits)))))) + (($ $kargs names vars + ($ $continue k src ($ $primcall 'ash (a b)))) + (match (intmap-ref cps k) + (($ $kargs (_) (result)) + (call-with-values (lambda () + (lookup-pre-type types label b)) + (lambda (b-type b-min b-max) + (values + (cond + ((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 + (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 + 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))))) + (values + (cond + ((f64-operands? a 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)))) + + (values (intmap-fold visit-cont cps cps #f #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 unboxable and whose uses +;; include an unbox operation. +(define (compute-specializable-vars cps body preds defs + exp-result-unboxable? + 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. + (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) (memq op unbox-ops))) (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) + ;; 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 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-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) + (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 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/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-specialization cps kfun body preds defs phis) + (define (compute-unbox-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 (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)) + (with-cps cps + (letv unboxed) + (let$ body (have-arg unboxed)) + (letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) + (build-term + ($continue kunboxed #f ($primcall (unbox-op def-var) (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)) + (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) + (intmap-fold (lambda (phi kind 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 (intmap-ref phis var (lambda (_) #f)) + (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 ((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 (box-op var) (unboxed))))) + (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)) + (box-results (unbox-operands))) + +(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-phis cps body preds defs))) + (if (eq? phis empty-intmap) + cps + (apply-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 + (specialize-phis (specialize-operations cps))))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index e5b76fb13..a52e34456 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -27,81 +27,61 @@ (define-module (language cps specialize-primcalls) #:use-module (ice-9 match) #:use-module (language cps) - #:use-module (language cps dfg) + #:use-module (language cps utils) + #:use-module (language cps intmap) #: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)))) +(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)))) + (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)))) + (define (specialize-primcall name args) + (define (rename name) + (build-exp ($primcall name args))) + (match (cons name args) + (('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)))) + (('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)) + (('scm->s64 (? s64?)) (rename 'load-s64)) + (_ #f))) + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars ($ $continue k src ($ $primcall name args))) + (let ((exp* (specialize-primcall name args))) + (if exp* + (build-cont + ($kargs names vars ($continue k src ,exp*))) + cont))) + (_ cont))) + conts))) diff --git a/module/language/cps2/split-rec.scm b/module/language/cps/split-rec.scm similarity index 78% rename from module/language/cps2/split-rec.scm rename to module/language/cps/split-rec.scm index 763ede570..2551ac643 100644 --- a/module/language/cps2/split-rec.scm +++ b/module/language/cps/split-rec.scm @@ -24,12 +24,12 @@ ;;; ;;; Code: -(define-module (language cps2 split-rec) +(define-module (language cps 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) + #:use-module (language cps utils) + #:use-module (language cps with-cps) #:use-module (language cps intmap) #:use-module (language cps intset) #:export (split-rec)) @@ -105,55 +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)) - ;; 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/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))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index ba66ec3ff..fc37fac50 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -26,9 +26,12 @@ (define-module (language cps type-fold) #:use-module (ice-9 match) #:use-module (language cps) - #:use-module (language cps dfg) + #: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)) @@ -88,10 +91,11 @@ (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))) + ;; 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) '=) @@ -104,30 +108,45 @@ ((<) (values #t #t)) ((= >= >) (values #t #f)) (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) ((< <= =) (values #t #t)) ((>) (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) ((=) (values #t #t)) ((< >) (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) ((> >= =) (values #t #t)) ((<) (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) ((>) (values #t #t)) ((= <= <) (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) @@ -152,124 +171,137 @@ (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) +(define-syntax-rule (define-unary-primcall-reducer (name cps k src + arg type min max) body ...) (define-primcall-reducer name - (lambda (dfg k src arg type min max) body ...))) + (lambda (cps 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) +(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 (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...))) + (lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1) + body ...))) -(define-binary-primcall-reducer (mul dfg k src +(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) - (let-fresh (kzero) (zero) - (build-cps-term - ($letk ((kzero ($kargs (#f) (zero) - ($continue k src ($primcall 'sub (zero arg)))))) - ($continue kzero src ($const 0)))))) + (with-cps cps + ($ (with-cps-constants ((zero 0)) + (build-term + ($continue k src ($primcall 'sub (zero arg)))))))) (define (zero) - (build-cps-term ($continue k src ($const 0)))) + (with-cps cps + (build-term ($continue k src ($const 0))))) (define (identity arg) - (build-cps-term ($continue k src ($values (arg))))) + (with-cps cps + (build-term ($continue k src ($values (arg)))))) (define (double arg) - (build-cps-term ($continue k src ($primcall 'add (arg 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)))))) - (let-fresh (kbits) (bits) - (build-cps-term - ($letk ((kbits ($kargs (#f) (bits) - ($continue k src ($primcall 'ash (arg bits)))))) - ($continue kbits src ($const n))))))) + (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) - (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 + ((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)) #f) + ((logtest (logior type0 type1) (lognot &number)) (fail)) ((= min0 max0) (mul/constant min0 type0 arg1 type1)) ((= min1 max1) (mul/constant min1 type1 arg0 type0)) - (else #f))) + (else (fail)))) -(define-binary-primcall-reducer (logbit? dfg k src +(define-binary-primcall-reducer (logbit? cps 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)))))))))) + (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))) - (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))))))))))) + (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 ($values (bool))))) + ($ (convert-to-logtest kbool))))) + (with-cps cps #f)))) ;; -(define (fold-and-reduce fun dfg min-label min-var) +(define (local-type-fold start end cps) (define (scalar-value type val) (cond ((eqv? type &exact-integer) val) @@ -281,163 +313,143 @@ ((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)) + (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) - (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) + (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 - ((arg) - (maybe-fold-unary-branch! label name arg)) + ((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) - (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))) + (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)))) + (($ $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) + (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-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 (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 fun) - (let* ((fun (renumber fun)) - (dfg (compute-dfg fun))) - (with-fresh-name-state-from-dfg dfg - (fold-constants* fun dfg)))) +(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 index 5e0b2d083..8464a6502 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,15 +57,16 @@ ;;; 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 ;;; 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). +;;; 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 @@ -78,11 +79,12 @@ (define-module (language cps types) #:use-module (ice-9 match) #:use-module (language cps) - #:use-module (language cps dfg) + #:use-module (language cps utils) #:use-module (language cps intmap) + #:use-module (language cps intset) #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #:use-module ((system syntax internal) #:select (syntax?)) #:export (;; Specific types. &exact-integer &flonum @@ -111,11 +113,16 @@ &bytevector &bitvector &array - &hash-table + &syntax ;; Union types. &number &real + ;; Untagged types. + &f64 + &u64 + &s64 + infer-types lookup-pre-type lookup-post-type @@ -163,7 +170,11 @@ &bytevector &bitvector &array - &hash-table) + &syntax + + &f64 + &u64 + &s64) (define-syntax &no-type (identifier-syntax 0)) @@ -172,9 +183,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 @@ -198,32 +206,50 @@ (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 &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 +;; 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 *max-codepoint* #x10ffff) (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)) @@ -251,8 +277,29 @@ ((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 + ((type-entry<=? b a) a) + (else + (make-type-entry + (logior (type-entry-type a) (type-entry-type b)) + (let ((a-min (type-entry-min a)) + (b-min (type-entry-min b))) + (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))) + (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 @@ -260,8 +307,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)) @@ -302,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)))) @@ -321,6 +369,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* @@ -464,7 +525,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?) @@ -499,7 +560,19 @@ 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))) + + + + +;;; +;;; Threads. We don't currently track threads as an object type. +;;; + +(define-simple-types + ((current-thread) &all-types)) @@ -546,27 +619,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 (&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*) - (define! result &vector (max (&min size) 0) (&max size))) + (restrict! size &u64 0 *max-vector-len*) + (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 &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)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max v))) + (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 &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)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max v)))) + (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) @@ -575,8 +649,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) - (min (&max v) *max-vector-len*))) + (define! result &u64 (&min/0 v) (&max/vector v))) @@ -588,35 +661,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 &u64 0 *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 +inf.0) - (check-type idx &exact-integer 0 +inf.0) + (and (check-type s &struct 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)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) + (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) - (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 &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)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s)))) + (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) (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*)) @@ -625,86 +698,130 @@ minimum, and maximum." ;;; 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) + (and (check-type s &string 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)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) - (define! result &char 0 *max-char*)) + (restrict! s &string (1+ (&min/0 idx)) *max-size-t*) + (restrict! idx &u64 0 (1- (&max/size s))) + (define! result &char 0 *max-codepoint*)) (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*) + (and (check-type s &string 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 idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) - (restrict! val &char 0 *max-char*)) + (restrict! s &string (1+ (&min/0 idx)) *max-size-t*) + (restrict! idx &u64 0 (1- (&max/size s))) + (restrict! val &char 0 *max-codepoint*)) (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 &u64 (&min/0 s) (&max/size s))) -(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)) + + +;;; +;;; Unboxed 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-aliases scm->f64 load-f64) + +(define-type-checker (f64->scm f64) + #t) +(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 &u64-max)) +(define-type-inferrer (scm->u64 scm result) + (restrict! scm &exact-integer 0 &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) + (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) + (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 (&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 s64) (&max/s64 s64))) + + ;;; ;;; 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-simple-type-checker (bv-length &bytevector)) +(define-type-inferrer (bv-length bv result) + (restrict! bv &bytevector 0 *max-size-t*) + (define! result &u64 (&min/0 bv) (&max/size bv))) -(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 &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 &exact-integer 0 (- (&max bv) size)) - (define! result type min max)) + (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 +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 &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/0 idx) size) *max-size-t*) + (restrict! idx &u64 0 (- (&max/size bv) 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-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-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-u16-ref bv-u16-set! &u64 2 0 #xffff) +(define-bytevector-accessors bv-s16-ref bv-s16-set! &s64 2 (- #x8000) #x7fff) -;; 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) +(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) @@ -738,17 +855,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 (< >=)) @@ -762,6 +882,71 @@ 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/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/0 a) (&min/0 b))) + (max (min (&max/u64 a) (&max/u64 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)) + ('<= (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/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))))) + +(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) @@ -787,63 +972,123 @@ 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*)) (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) +(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)) (+ (&max a) (&max b)))) +(define-type-inferrer (fadd a b result) + (define! result &f64 + (+ (&min a) (&min b)) + (+ (&max a) (&max b)))) +(define-type-inferrer (uadd a b result) + ;; Handle wraparound. + (let ((max (+ (&max/u64 a) (&max/u64 b)))) + (if (<= max &u64-max) + (define! result &u64 (+ (&min/0 a) (&min/0 b)) max) + (define! result &u64 0 &u64-max)))) +(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) (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-type-inferrer (usub a b result) + ;; Handle wraparound. + (let ((min (- (&min/0 a) (&max/u64 b)))) + (if (< min 0) + (define! result &u64 0 &u64-max) + (define! result &u64 min (- (&max/u64 a) (&min/0 b)))))) +(define-type-aliases usub usub/immediate) (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)) + (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))) - (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 -- -+ ++ +-))))))) + (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))))) + (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-inferrer (umul a b result) + ;; Handle wraparound. + (let ((max (* (&max/u64 a) (&max/u64 b)))) + (if (<= max &u64-max) + (define! result &u64 (* (&min/0 a) (&min/0 b)) max) + (define! result &u64 0 &u64-max)))) +(define-type-aliases umul umul/immediate) (define-type-checker (div a b) (and (check-type a &number -inf.0 +inf.0) @@ -851,39 +1096,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-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-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-type-checker (quo a b) (and (check-type a &exact-integer -inf.0 +inf.0) @@ -986,11 +1232,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))) @@ -1004,6 +1250,29 @@ 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/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/u64 b) 64) + (<= (ash (&max/u64 a) (&max/u64 b)) &u64-max)) + ;; No overflow; we can be precise. + (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) + (define (next-power-of-two n) (let lp ((out 1)) (if (< n out) @@ -1026,6 +1295,43 @@ 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/u64 a) (&max/u64 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 (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/u64 a))) + (define-simple-type-checker (logior &exact-integer &exact-integer)) (define-type-inferrer (logior a b result) ;; Saturate all bits of val. @@ -1047,9 +1353,23 @@ 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/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) +(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) @@ -1101,7 +1421,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)))))))) @@ -1111,19 +1431,15 @@ minimum, and maximum." ;;; Characters. ;;; -(define-simple-type (char=? char>?) - -(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff))) +(define-simple-type-checker (integer->char (&u64 0 *max-codepoint*))) (define-type-inferrer (integer->char i result) - (restrict! i &exact-integer 0 #x10ffff) - (define! result &char (max (&min i) 0) (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 &exact-integer (max (&min c) 0) (min (&max c) #x10ffff))) + (restrict! c &char 0 *max-codepoint*) + (define! result &u64 (&min/0 c) (min (&max c) *max-codepoint*))) @@ -1132,293 +1448,262 @@ minimum, and maximum." ;;; 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 (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 (get-entry label) (vector-ref typev (label->idx label))) +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) - (define (in-types entry) (vector-ref entry 0)) - (define (out-types entry succ) (vector-ref entry (1+ succ))) +(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 (update-in-types! entry types) - (vector-set! entry 0 types)) - (define (update-out-types! entry succ types) - (vector-set! entry (1+ succ) types)) +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) - (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))))) +(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)))))) - ;; Initial state: nothing flows into the $kfun. - (let ((entry (get-entry min-label))) - (update-in-types! entry empty-intmap))) +;; 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. - (define (adjoin-vars types vars entry) - (match vars - (() types) - ((var . vars) - (adjoin-vars (adjoin-var types var entry) vars entry)))) +A type entry is a vector that describes the types of the values that +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 +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 (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 (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 (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 (adjoin-vars types vars entry) + (match vars + (() types) + ((var . vars) + (adjoin-vars (adjoin-var types var entry) vars entry)))) - (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 (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 (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) + (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 ((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)))))))) + (let ((body-types (adjoin-vars types defs all-types-entry))) + (if kalt + (propagate2 kbody body-types kalt types) + (propagate1 kbody body-types)))))) + (($ $ktail) (propagate0))))) - (prepare-initial-state!) + (worklist-fold* visit-cont + (intset-add empty-intset kfun) + (compute-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))) +(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)))) - ;; And loop. - (lp (1+ label))) +(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)))) - ;; 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) +(define (primcall-types-check? types 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))))))) + (let ((entry (intmap-ref types label))) + (apply checker (vector-ref entry 0) args))))) diff --git a/module/language/cps2/utils.scm b/module/language/cps/utils.scm similarity index 59% rename from module/language/cps2/utils.scm rename to module/language/cps/utils.scm index d375925c9..3fce00a99 100644 --- a/module/language/cps2/utils.scm +++ b/module/language/cps/utils.scm @@ -22,11 +22,11 @@ ;;; ;;; Code: -(define-module (language cps2 utils) +(define-module (language cps utils) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (language cps2) + #:use-module (language cps) #:use-module (language cps intset) #:use-module (language cps intmap) #:export (;; Fresh names. @@ -37,7 +37,10 @@ ;; Various utilities. fold1 fold2 + trivial-intset intmap-map + intmap-keys + invert-bijection invert-partition intset->intmap worklist-fold fixpoint @@ -45,13 +48,16 @@ ;; 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 + solve-flow-equations )) (define label-counter (make-parameter #f)) @@ -108,11 +114,38 @@ (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))) + (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}." + (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 @@ -149,9 +182,11 @@ (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 @@ -165,14 +200,41 @@ 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 'load-s64) (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 (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)) + (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) s64 #x7fffFFFFffffFFFF)) + (intmap-add! out var s64) + 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 @@ -201,7 +263,45 @@ (visit-cont k labels)) (_ labels))))))))))) -(define (compute-successors 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." + (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) @@ -223,8 +323,8 @@ (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) @@ -305,6 +405,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) @@ -353,3 +505,46 @@ partitioning the labels into strongly connected components (SCCs)." (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 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 +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 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))))))) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 6c2310737..1a9eb72e3 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -1,195 +1,304 @@ -;;; 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 +;;; 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 (srfi srfi-26) #:use-module (language cps) - #:export (verify-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 (verify-cps fun) - (define seen-labels (make-hash-table)) - (define seen-vars (make-hash-table)) +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) - (define (add sym seen env) - (when (hashq-ref seen sym) - (error "duplicate gensym" sym)) - (hashq-set! seen sym #t) - (cons sym env)) +(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 (add-env new seen env) - (if (null? new) - env - (add-env (cdr new) seen (add (car new) seen env)))) +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) - (define (add-vars new env) - (unless (and-map exact-integer? new) - (error "bad vars" new)) - (add-env new seen-vars env)) +(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 (add-labels new env) - (unless (and-map exact-integer? new) - (error "bad labels" new)) - (add-env new seen-labels env)) +(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 (check-ref sym seen env) - (cond - ((not (hashq-ref seen sym)) - (error "unbound lexical" sym)) - ((not (memq sym env)) - (error "displaced lexical" sym)))) + (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 (check-label sym env) - (check-ref sym seen-labels env)) + (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))) - (define (check-var sym env) - (check-ref sym seen-vars env)) + (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))))) - (define (check-src src) - (if (and src (not (and (list? src) (and-map pair? src) - (and-map symbol? (map car src))))) - (error "bad src"))) + (worklist-fold* visit-cont + (intset kfun) + (intmap-add empty-intmap kfun empty-intset))) - (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 (intmap-for-each f map) + (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) - (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 (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 (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 (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 (visit-fun fun k-env v-env) - (match fun - (($ $fun entry) - (visit-entry entry '() v-env)) - (_ - (error "unexpected $fun" fun)))) +(define (compute-reachable-labels conts kfun) + (intmap-fold (lambda (kfun body seen) (intset-union seen body)) + (compute-reachable-functions conts kfun) + empty-intset)) - (define (visit-expression exp k-env v-env) +(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 - (($ $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)) + ((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) + (error "primitive should continue to $kargs, not $ktail" name)))) (($ $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)))) + (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 (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))) +(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))) - (($ $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) +(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/cps/with-cps.scm similarity index 98% rename from module/language/cps2/with-cps.scm rename to module/language/cps/with-cps.scm index f14eb93c9..45cb9c4fd 100644 --- a/module/language/cps2/with-cps.scm +++ b/module/language/cps/with-cps.scm @@ -98,9 +98,9 @@ ;;; ;;; Code: -(define-module (language cps2 with-cps) - #:use-module (language cps2) - #:use-module (language cps2 utils) +(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)) 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/compile-cps.scm b/module/language/cps2/compile-cps.scm deleted file mode 100644 index e505233ca..000000000 --- a/module/language/cps2/compile-cps.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: -;;; -;;; 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 optimize) - #: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) - (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 0)) - -(define (compile-cps exp env opts) - (let ((exp (renumber (optimize exp opts)))) - (values (conts->fun exp) env env))) 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 28ef04f23..000000000 --- a/module/language/cps2/dce.scm +++ /dev/null @@ -1,378 +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-exps live-vars) - (match exp - ((or ($ $const) ($ $prim)) - (values live-exps live-vars)) - (($ $fun body) - (visit-fun body live-exps live-vars)) - (($ $rec names vars (($ $fun kfuns) ...)) - (let lp ((vars vars) (kfuns kfuns) - (live-exps live-exps) (live-vars live-vars)) - (match (vector vars kfuns) - (#(() ()) (values live-exps 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)))))) - (($ $prompt escape? tag handler) - (values live-exps (adjoin-var tag live-vars))) - (($ $call proc args) - (values live-exps (adjoin-vars args (adjoin-var proc live-vars)))) - (($ $callk k proc args) - (values live-exps (adjoin-vars args (adjoin-var proc live-vars)))) - (($ $primcall name args) - (values live-exps (adjoin-vars args live-vars))) - (($ $branch k ($ $primcall name args)) - (values live-exps (adjoin-vars args live-vars))) - (($ $branch k ($ $values (arg))) - (values live-exps (adjoin-var arg live-vars))) - (($ $values args) - (values live-exps - (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-exps live-vars) - (cond - ((intset-ref live-exps label) - ;; Expression live already. - (visit-live-exp label k exp live-exps 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-exps label) live-vars)) - (else - ;; Still dead. - (values live-exps live-vars)))) - - (define (visit-fun label live-exps live-vars) - ;; Visit uses before definitions. - (postorder-fold-local-conts2 - (lambda (label cont live-exps live-vars) - (match cont - (($ $kargs _ _ ($ $continue k src exp)) - (visit-exp label k exp live-exps live-vars)) - (($ $kreceive arity kargs) - (values live-exps live-vars)) - (($ $kclause arity kargs kalt) - (values live-exps (adjoin-vars (cont-defs kargs) live-vars))) - (($ $kfun src meta self) - (values live-exps (adjoin-var self live-vars))) - (($ $ktail) - (values live-exps live-vars)))) - conts label live-exps live-vars)) - - (fixpoint (lambda (live-exps live-vars) - (visit-fun 0 live-exps live-vars)) - empty-intset - 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-exps live-vars) - (define (exp-live? label) - (intset-ref live-exps 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 (exp-live? label) - (match exp - (($ $fun body) - (values (visit-fun body 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 (fold1 (lambda (fun cps) - (match fun - (($ $fun kfun) - (visit-fun kfun cps)))) - funs 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))))) - (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)))) - -(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-exps live-vars) - (process-eliminations conts live-exps 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 a41c5f2a3..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)) - (&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 3d4bb2753..000000000 --- a/module/language/cps2/optimize.scm +++ /dev/null @@ -1,90 +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)) - -(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* (optimize program #:optional (opts '())) - (define (run-pass! pass kw default) - (set! program - (if (kw-arg-ref opts kw default) - (maybe-verify (pass program)) - program))) - - (maybe-verify program) - - ;; 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)) 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/renumber.scm b/module/language/cps2/renumber.scm deleted file mode 100644 index 2c07e03a4..000000000 --- a/module/language/cps2/renumber.scm +++ /dev/null @@ -1,205 +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 (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)) - (_ (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 685327a40..000000000 --- a/module/language/cps2/simplify.scm +++ /dev/null @@ -1,279 +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)) - (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 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)) - (persistent-intset - (worklist-fold visit-funs (intset-add empty-intset 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 nested-funs beta) - (let* ((body (compute-function-body conts kfun)) - (single (compute-singly-referenced-labels conts body))) - (define (visit-cont label nested-funs 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)) - (_ - (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)) - (persistent-intset - (worklist-fold visit-funs (intset-add empty-intset 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)) - ,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/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/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 6fca57d73..000000000 --- a/module/language/cps2/types.scm +++ /dev/null @@ -1,1407 +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))) - (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 (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/verify.scm b/module/language/cps2/verify.scm deleted file mode 100644 index 8d5504282..000000000 --- a/module/language/cps2/verify.scm +++ /dev/null @@ -1,303 +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)) - (define (visit-exp exp bound) - (define (check-use var) - (unless (intset-ref bound var) - (error "unbound var" var))) - (match exp - ((or ($ $const) ($ $prim)) #t) - ;; todo: $closure - (($ $fun kfun) - (visit-fun kfun bound)) - (($ $rec names vars (($ $fun kfuns) ...)) - (let ((bound (fold1 adjoin-def vars bound))) - (for-each (lambda (kfun) (visit-fun kfun bound)) kfuns))) - (($ $values args) - (for-each check-use args)) - (($ $call proc args) - (check-use proc) - (for-each check-use args)) - (($ $callk k proc args) - (check-use proc) - (for-each check-use args)) - (($ $branch kt ($ $values (arg))) - (check-use arg)) - (($ $branch kt ($ $primcall name args)) - (for-each check-use args)) - (($ $primcall name args) - (for-each check-use args)) - (($ $prompt escape? tag handler) - (check-use tag)))) - (intmap-for-each - (lambda (label bound) - (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)))) - -(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 (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 (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)))) - -(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))))) - -(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/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/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-cps2.scm b/module/language/tree-il/compile-cps.scm similarity index 83% rename from module/language/tree-il/compile-cps2.scm rename to module/language/tree-il/compile-cps.scm index 932a49d27..3e1c1d44c 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 @@ -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 @@ -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) @@ -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) @@ -506,6 +509,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) @@ -555,6 +570,117 @@ ($ (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)) + ((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) + (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) + (with-cps cps + (letv unboxed) + (let$ body (have-arg unboxed)) + (letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) + (build-term + ($continue kunboxed src ($primcall unbox-op (arg)))))) + (define (unbox-args cps args have-args) + (case instruction + ((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 + 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 idx 'scm->u64 + (lambda (cps idx) + (unbox-arg + 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))))))))) + ((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! string-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))))))) + ((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) ;; Tree-IL primcalls are sloppy, in that it could be @@ -566,10 +692,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) @@ -653,7 +783,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 @@ -661,6 +791,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 @@ -671,7 +808,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 @@ -818,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 @@ -892,6 +1030,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))) @@ -931,7 +1079,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/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/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/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/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index fca849ec0..993fa0ad6 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) @@ -511,7 +510,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 _ @@ -944,26 +951,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 @@ -1005,10 +1021,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 "))) @@ -1084,6 +1096,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 @@ -1183,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) @@ -1357,7 +1406,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..90c1d2d1a 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -21,13 +21,14 @@ (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) #: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? @@ -83,7 +84,7 @@ current-module define! - 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 @@ -171,7 +172,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 +195,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. @@ -313,16 +314,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 +389,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 +408,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 / @@ -553,6 +550,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 @@ -583,7 +598,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/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) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 5a5d469eb..a46918062 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -62,7 +62,7 @@ - + ;; Numbers. @@ -74,8 +74,8 @@ ;; corresponding classes, which may be obtained via class-of, ;; once you have an instance. Perhaps FIXME to provide a ;; smob-type-name->class procedure. - - + + @@ -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) @@ -1009,6 +1009,8 @@ 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 () #:metaclass ) @@ -1332,7 +1334,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)) @@ -3095,7 +3097,10 @@ var{initargs}." ;;; {SMOB and port classes} ;;; -(define (find-subclass ')) +(begin-deprecated + (define-public (find-subclass ')) + (define-public (find-subclass '))) + (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) @@ -3104,7 +3109,6 @@ var{initargs}." (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) -(define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) diff --git a/module/rnrs.scm b/module/rnrs.scm index a132c5364..d2b4cb3f6 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -160,11 +160,17 @@ ;; (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 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 @@ -183,7 +189,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/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/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm index 98d2d7616..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))) @@ -122,8 +127,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) @@ -143,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) @@ -178,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/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 2968dbd9f..594606785 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? @@ -63,10 +66,12 @@ 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 open-file-input/output-port + make-custom-binary-input/output-port ;; binary output put-u8 put-bytevector @@ -100,12 +105,16 @@ 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) + (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) @@ -167,6 +176,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 @@ -310,8 +346,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) @@ -350,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 @@ -382,6 +423,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)) @@ -396,7 +447,7 @@ return the characters accumulated in that port." (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 @@ -437,7 +488,7 @@ return the characters accumulated in that port." (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'. 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' diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 832b43606..4634623fe 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -31,66 +31,67 @@ ;;; Code: (define-module (srfi srfi-18) - :use-module (srfi srfi-34) - :export ( + #: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 + condition)) + #: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 + 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 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 + join-timeout-exception? + abandoned-mutex-exception? + terminated-thread-exception? + uncaught-exception? + uncaught-exception-reason) + #:re-export ((srfi-34:raise . raise)) + #:replace (current-time + current-thread + thread? + make-thread + make-mutex + mutex? + make-condition-variable + condition-variable?)) -(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)) @@ -100,72 +101,68 @@ (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)) +(define-record-type + (%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!) + (abandoned? mutex-abandoned? set-mutex-abandoned?!)) + +(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-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 -(define raise (@ (srfi srfi-34) raise)) -(define (initial-handler obj) - (srfi-18-exception-preserver (cons uncaught-exception 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-preserver obj) - (if (or (terminated-thread-exception? obj) - (uncaught-exception? obj)) - (set! (thread->exception (current-thread)) obj))) - -(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'. - - (and (not (eq? key 'srfi-34)) - (srfi-18-exception-preserver (if (null? args) - (cons uncaught-exception key) - (cons* uncaught-exception key args))))) - -(define (current-handler-stack) - (let ((ct (current-thread))) - (or (hashq-ref thread-exception-handlers ct) - (hashq-set! thread-exception-handlers ct (list initial-handler))))) +(define current-exception-handler + (make-parameter exception-handler-for-foreign-threads)) (define (with-exception-handler handler thunk) - (let ((ct (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))) - -(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)) + (parameterize ((current-exception-handler prev-handler)) + (handler obj)))) + (lambda () + (parameterize ((current-exception-handler handler)) + (thunk))))) ;; THREADS @@ -173,59 +170,59 @@ ;; 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 () - (lock-mutex lmutex) - (signal-condition-variable lcond) - (lock-mutex smutex) - (unlock-mutex lmutex) - (wait-condition-variable scond smutex) - (unlock-mutex smutex) - (with-exception-handler initial-handler - thunk))))) - (lambda (thunk . name) - (let ((n (and (pair? name) (car name))) +(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-owner mutex) thread) + (abandon-mutex! mutex))) + mutexes)))))) - (lm (make-mutex 'launch-mutex)) - (lc (make-condition-variable 'launch-condition-variable)) - (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))) - (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) - t))))) - -(define (thread-name thread) - (hashq-ref object-names (check-arg-type thread? thread "thread-name"))) - -(define (thread-specific thread) - (hashq-ref object-specifics - (check-arg-type thread? thread "thread-specific"))) - -(define (thread-specific-set! thread obj) - (hashq-set! object-specifics - (check-arg-type thread? thread "thread-specific-set!") - obj) - *unspecified*) +(define* (make-thread thunk #:optional name) + (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 ((prim (threads:call-with-new-thread + (lambda () + (catch #t + (lambda () + (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) + thread))) (define (thread-start! thread) - (let ((x (hashq-ref thread-start-conds - (check-arg-type 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))) - thread)) + (match (thread-start-conds thread) + ((smutex . scond) + (set-thread-start-conds! thread #f) + (mutex-lock! smutex) + (condition-variable-signal! scond) + (mutex-unlock! smutex)) + (#f #f)) + thread) -(define (thread-yield!) (yield) *unspecified*) +(define (thread-yield!) (threads:yield) *unspecified*) (define (thread-sleep! timeout) (let* ((ct (time->seconds (current-time))) @@ -237,129 +234,119 @@ '())))) (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 -;; 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))) - -;; A pass-thru to cancel-thread that first installs a handler that throws -;; terminated-thread exception, as per SRFI-18, +(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 unique value. +(define %cancel-sentinel (list 'cancelled)) (define (thread-terminate! thread) - (define (thread-terminate-inner!) - (let ((current-handler (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) - *unspecified*)) - (thread-terminate-inner!)) - -(define (thread-join! thread . args) - (define thread-join-inner! - (wrap (lambda () - (let ((v (apply join-thread thread args)) - (e (thread->exception thread))) - (if (and (= (length args) 1) (not v)) - (raise join-timeout-exception)) - (if e (raise e)) - v)))) - (call/cc thread-join-inner!)) - -;; 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 ((@ (guile) 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"))) - -(define (mutex-specific mutex) - (hashq-ref object-specifics - (check-arg-type mutex? mutex "mutex-specific"))) - -(define (mutex-specific-set! mutex obj) - (hashq-set! object-specifics - (check-arg-type mutex? mutex "mutex-specific-set!") - obj) + (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)) + (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 + +(define* (make-mutex #:optional name) + (%make-mutex (threads:make-mutex 'allow-external-unlock) name #f #f #f)) + (define (mutex-state mutex) - (let ((owner (mutex-owner mutex))) - (if owner - (if (thread-exited? owner) 'abandoned owner) - (if (> (mutex-level mutex) 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 (mutex-lock! mutex . args) - (define mutex-lock-inner! - (wrap (lambda () - (catch 'abandoned-mutex-error - (lambda () (apply lock-mutex mutex args)) - (lambda (key . args) (raise abandoned-mutex-exception)))))) - (call/cc mutex-lock-inner!)) +(define (abandon-mutex! mutex) + (set-mutex-abandoned?! mutex #t) + (threads:unlock-mutex (mutex-prim mutex))) -(define (mutex-unlock! mutex . args) - (apply unlock-mutex 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 () + (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)))) + #t) + (else #f))))) + +(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. -(define make-condition-variable - (lambda name - (let ((n (and (pair? name) (car name))) - (m ((@ (guile) 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? - condition-variable - "condition-variable-name"))) - -(define (condition-variable-specific condition-variable) - (hashq-ref object-specifics (check-arg-type condition-variable? - condition-variable - "condition-variable-specific"))) - -(define (condition-variable-specific-set! condition-variable obj) - (hashq-set! object-specifics - (check-arg-type condition-variable? - condition-variable - "condition-variable-specific-set!") - obj) - *unspecified*) +(define* (make-condition-variable #:optional name) + (%make-condition-variable (threads:make-condition-variable) name #f)) (define (condition-variable-signal! cond) - (signal-condition-variable cond) + (threads:signal-condition-variable (condition-variable-prim cond)) *unspecified*) (define (condition-variable-broadcast! cond) - (broadcast-condition-variable cond) + (threads:broadcast-condition-variable (condition-variable-prim cond)) *unspecified*) ;; TIME diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 6d86ee638..9cf9a2eb5 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-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 @@ -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) @@ -332,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-nanosecond tai) + (time-second tai)))) (define (current-time-thread) (time-error 'current-time 'unsupported-clock-type 'time-thread)) @@ -1001,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) @@ -1059,7 +1053,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/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 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))) diff --git a/module/statprof.scm b/module/statprof.scm index e613aad2d..59a2f12d0 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-2017 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2009 Andy Wingo ;;;; Copyright (C) 2001 Rob Browning ;;;; @@ -23,85 +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 -;;; 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 -;;; -;;; 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 -;;; @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: @@ -109,7 +32,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) @@ -146,8 +71,6 @@ statprof-fetch-call-tree statprof - with-statprof - gcprof)) @@ -327,10 +250,8 @@ (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)))))))) + (write-sample-and-continue + (frame-instruction-pointer-or-primitive-procedure-name frame)))))) (define (reset-sigprof-timer usecs) ;; Guile's setitimer binding is terrible. @@ -354,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) @@ -374,17 +297,9 @@ (define (count-call frame) (let ((state (existing-profiler-state))) (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)))) + (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))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -493,6 +408,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)) @@ -539,19 +474,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) @@ -560,10 +495,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) @@ -594,11 +529,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 @@ -606,16 +543,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}." @@ -639,16 +588,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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -661,8 +601,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 @@ -684,10 +623,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)) @@ -702,10 +639,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" "") @@ -715,11 +652,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 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-anomalies #:optional (state (existing-profiler-state))) @@ -730,15 +667,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. " @@ -764,15 +701,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?) @@ -801,32 +729,136 @@ to @code{statprof-reset}." n-terminal (acons (caar in) (list (cdar in)) tails)))))) -(define* (statprof-fetch-call-tree #:optional (state (existing-profiler-state))) +(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)) + #: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) - (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 + (or (and (not precise?) + (and=> pdi program-debug-info-addr)) + callee)) + source->string))) + (if loc + (string-append name " at " loc) + name))) (else (with-output-to-string (lambda () (write callee)))))) - (define (memoizev/1 proc table) - (lambda (x) - (cond - ((hashv-get-handle table x) => cdr) - (else - (let ((res (proc x))) - (hashv-set! table x res) - res))))) - (let ((callee->printable (memoizev/1 callee->printable (make-hash-table)))) - (cons #t (lists->trees (map (lambda (callee-list) - (map callee->printable 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) + ((#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)) @@ -834,7 +866,8 @@ The return value is a list of nodes, each of which is of the type: (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 @@ -860,14 +893,18 @@ 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. +(begin-deprecated + (define-macro (with-statprof . args) + "Profile the expressions in the body, and return the body's return values. 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 @@ -881,22 +918,25 @@ 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)) + #: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))) + (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}. @@ -916,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) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index d6a53d6b3..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 @@ -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 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?) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 249961d79..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)) @@ -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 () @@ -243,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)) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index d60a8e0af..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" "sh4")) + "powerpcle" "powerpc64le" "mipsel" "mips64el" "nios2" "sh3" "sh4" "alpha")) (endianness little)) ((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu" "mips" "mips64" "m68k" "s390x")) @@ -102,8 +102,8 @@ ((string-match "64$" cpu) 8) ((string-match "64_?[lbe][lbe]$" cpu) 8) - ((member cpu '("sparc" "powerpc" "mips" "mipsel" "m68k" "sh4")) 4) - ((member cpu '("s390x")) 8) + ((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))))) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 26760d1d1..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,13 +16,14 @@ (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) #: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) @@ -42,9 +43,6 @@ inferior-object-sub-kind inferior-object-address - inferior-fluid? - inferior-fluid-number - inferior-struct? inferior-struct-name inferior-struct-fields @@ -99,7 +97,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))) @@ -117,8 +115,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." @@ -239,29 +241,30 @@ 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-syntax #x3d) +(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 #x77) (define %tc16-bignum (+ %tc7-number (* 1 256))) (define %tc16-real (+ %tc7-number (* 2 256))) @@ -307,21 +310,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. @@ -440,7 +428,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))) @@ -455,8 +443,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)) @@ -478,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/repl/command.scm b/module/system/repl/command.scm index 62bc2977a..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) @@ -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. diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index f0e6e03a0..42d5c24ae 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-2014 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 diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm index c19dda191..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,14 +25,19 @@ #: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!)) #: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! + make-tcp-server-socket guard-against-http-request) + (define-record-type (%make-coop-repl-server mutex queue) coop-repl-server? @@ -173,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/debug.scm b/module/system/repl/debug.scm index 300145d16..383d37921 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 @@ -24,16 +24,18 @@ #:use-module (system base language) #: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 ( 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)) @@ -94,12 +96,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))) @@ -113,7 +116,7 @@ (format port "~aLocal variables:~%" per-line-prefix) (for-each (lambda (binding) - (let ((v (frame-local-ref frame (binding-slot 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))) @@ -134,7 +137,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 " ")))) @@ -160,32 +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))) - (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))) @@ -204,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 @@ -227,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/module/system/repl/server.scm b/module/system/repl/server.scm index ff9ee5cbc..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 @@ -78,15 +84,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 +104,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 @@ -132,16 +122,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)) @@ -149,16 +139,192 @@ (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)))))) + (guard-against-http-request client) + + (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)))) + + +;;; +;;; 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: diff --git a/module/language/tree-il/inline.scm b/module/system/syntax.scm similarity index 57% rename from module/language/tree-il/inline.scm rename to module/system/syntax.scm index 5a2d9af55..34fadb39f 100644 --- a/module/language/tree-il/inline.scm +++ b/module/system/syntax.scm @@ -1,6 +1,6 @@ -;;; a simple inliner +;;; Syntax utilities -;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;; 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 @@ -16,10 +16,18 @@ ;;;; 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!)) +;;; Code: -(define (inline! x) - (issue-deprecation-warning - "`inline!' is deprecated. Use (language tree-il peval) instead.") - x) +(define-module (system syntax) + #:use-module (system syntax internal) + #: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 6bc2bcf84..8d71dc551 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) @@ -58,17 +59,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 @@ -89,91 +93,144 @@ 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-mov* . emit-mov) - (emit-box* . emit-box) - (emit-box-ref* . emit-box-ref) - (emit-box-set!* . emit-box-set!) + emit-br-if-eq + emit-br-if-eqv + emit-br-if-= + emit-br-if-< + emit-br-if-<= + emit-br-if-logtest + 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-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! 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-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-add1* . emit-add1) - (emit-sub* . emit-sub) - (emit-sub1* . emit-sub1) - (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-logand* . emit-logand) - (emit-logior* . emit-logior) - (emit-logxor* . emit-logxor) - (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-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) - (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-push-dynamic-state + emit-pop-dynamic-state + emit-current-thread + emit-fluid-ref + emit-fluid-set! + emit-string-length + emit-string-ref + emit-string-set! + 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-ulogxor + emit-ulogsub + emit-ursh + emit-ulsh + emit-ursh/immediate + emit-ulsh/immediate + emit-char->integer + emit-integer->char + 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-load-f64 + emit-f64->scm + emit-scm->u64 + emit-scm->u64/truncate + emit-load-u64 + emit-u64->scm + emit-scm->s64 + emit-load-s64 + 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-make-atomic-box + emit-atomic-box-ref + emit-atomic-box-set! + emit-atomic-box-swap! + emit-atomic-box-compare-and-swap! + emit-handle-interrupts emit-text link-assembly)) @@ -197,73 +254,80 @@ ;;; Bytecode consists of 32-bit units, often subdivided in some way. ;;; These helpers create one 32-bit unit from multiple components. +(define-inline (check-urange x mask) + (let ((x* (logand x mask))) + (unless (= x x*) + (error "out of range" x)) + 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) - (unless (<= 0 x 255) - (error "out of range" x)) - (logior x (ash y 8))) + (let ((x (check-urange x #xff)) + (y (check-urange y #xffffff))) + (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 (check-urange x #xff)) + (y (check-srange y #xffffff))) + (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 (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) - (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 (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) - (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 (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) - (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 (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 (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. -(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)) +(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!) @@ -307,9 +371,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. @@ -319,41 +380,31 @@ ;;; 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 shstrtab next-section-number meta sources - dead-slot-maps) + 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-idx 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. ;; - (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 - ;; 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!) - ;; 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. ;; @@ -403,22 +454,18 @@ ;; (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!)) - -(define-inline (fresh-block) - (make-u32vector *block-size*)) + (slot-maps asm-slot-maps set-asm-slot-maps!)) (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 '() @@ -429,28 +476,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." + (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 @@ -492,7 +531,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) @@ -510,45 +549,67 @@ 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) - (emit asm (pack-u8-u8-u16 opcode a (object-address imm)))) - ((U8_U12_U12 a b) + ((X8_S8_I16 a 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))) - ((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))) - (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)) + (emit asm (logand u64 (1- (ash 1 32)))))) + ((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) (emit asm 0)) - ((S32 label) + ((R32 label) (record-far-label-reference asm label) (emit asm 0)) ((L32 label) @@ -556,40 +617,269 @@ later by the linker." (emit asm 0)) ((LO32 label offset) (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) + (* offset (asm-word-size asm))) (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* ...) + ((_ 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* ... ...) - (unless (asm? asm) (error "not an asm")) + ;; 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)) + (bytevector-length (asm-buf asm))) + (grow-buffer! asm) + (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)) @@ -600,7 +890,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))))))) @@ -617,163 +907,25 @@ later by the linker." (visit-opcodes define-assembler) -(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). - ;; - ;; 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. - - (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 - ((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) - (values (if (< a (ash 1 8)) a 253) - imm)) - ((U8_U12_U12 ! 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) - (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) - (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) - (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)))))) - - (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 - (U8_U24 a b) - (U8_L24 a label) - (U32 a) - (I32 imm) - (A32 imm) - (B32) - (N32 label) - (S32 label) - (L32 label) - (LO32 label offset) - (X8_U24 a) - (X8_L24 label) - (B1_X7_L24 a label) - (B1_U7_L24 a b label) - (B1_X31 a) - (B1_X7_U24 a b))) - - (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 - ((U8_U8_I16 U8_U8_U8_U8) - (unless (< dst (ash 1 8)) - (emit-mov* asm dst 253))) - ((U8_U12_U12) - (unless (< dst (ash 1 12)) - (emit-mov* asm dst 253)))))) - - (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 ...)))))) - - (define-syntax define-shuffling-assembler - (lambda (stx) - (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)))))))) - -(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))) (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) (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) @@ -802,9 +954,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 (immediate-bits asm x) + "Return the bit pattern to write into the buffer if @var{x} is +immediate, and @code{#f} otherwise." + (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 (- #x20000000) + #x1fffffff)) + ((8) (values (- #x2000000000000000) + #x1fffffffFFFFFFFF)) + (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) @@ -835,13 +1010,16 @@ lists. This procedure can be called many times before calling (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 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 @@ -869,11 +1047,17 @@ 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)))) ((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))) @@ -908,7 +1092,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. @@ -921,7 +1105,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)) @@ -959,15 +1143,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 @@ -989,27 +1173,28 @@ 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-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) ;(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) @@ -1063,19 +1248,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 @@ -1085,8 +1257,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 @@ -1099,8 +1270,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) @@ -1121,8 +1291,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))) @@ -1130,11 +1299,10 @@ 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 - (* (- (asm-start asm) (arity-low-pc arity)) 4)))) + (def (vector name slot representation + (- (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) @@ -1154,12 +1322,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))))) @@ -1191,14 +1358,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 @@ -1210,8 +1379,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)))) @@ -1223,19 +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 stringbuf-shared-flag #x100) + (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 stringbuf-shared-flag)) - (define tc7-wide-stringbuf - (+ tc7-stringbuf stringbuf-shared-flag stringbuf-wide-flag)) - (define tc7-ro-string (+ 21 #x200)) - (define tc7-program 69) - (define tc7-bytevector 77) - (define tc7-bitvector 95) - (define tc7-array 93) + + (define tc7-syntax #x3d) + + (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))) @@ -1256,6 +1433,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) @@ -1266,17 +1445,22 @@ 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 ((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) @@ -1315,19 +1499,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? + (let ((tag (logior tc7-string string-read-only-flag))) (case word-size ((4) - (bytevector-u32-set! buf pos tc7-ro-string endianness) - (write-immediate asm buf (+ pos 4) #f) ; stringbuf + (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) - (write-immediate asm buf (+ pos 8) #f) ; stringbuf + (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)) (else (error "bad word size"))))) @@ -1338,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)) @@ -1351,19 +1535,36 @@ 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)) + + ((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-immediate asm buf pos #f)) + (write-placeholder asm buf pos)) ((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) @@ -1373,7 +1574,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) @@ -1382,16 +1583,19 @@ 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) (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 @@ -1403,7 +1607,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)) @@ -1449,11 +1653,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))) @@ -1484,23 +1688,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))))))) '() @@ -1510,41 +1720,21 @@ 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) - "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-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))))))) + (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)) + (byte-swap/4! buf)) + (make-object asm '.rtl-text + buf + (process-relocs buf (asm-relocs asm) + (asm-labels asm)) + (process-labels (asm-labels asm))))) @@ -1572,7 +1762,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) @@ -1586,7 +1776,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) @@ -1597,7 +1787,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)) @@ -1617,7 +1807,7 @@ needed." ;; FIXME: Define these somewhere central, shared with C. (define *bytecode-major-version* #x0202) -(define *bytecode-minor-version* 6) +(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}, @@ -1693,9 +1883,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))))) @@ -1810,8 +2000,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)) @@ -1845,7 +2035,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))) @@ -1855,9 +2045,15 @@ 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) + ((u64) 2) + ((s64) 3) + (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 @@ -1952,7 +2148,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)) @@ -2018,7 +2214,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)) @@ -2079,14 +2275,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))))) @@ -2134,6 +2330,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 @@ -2159,7 +2356,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. @@ -2231,12 +2428,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) @@ -2245,11 +2444,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/debug.scm b/module/system/vm/debug.scm index cd8c19e13..09d076692 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,16 @@ 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) + ((2) 'u64) + ((3) 's64) + (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) @@ -463,19 +470,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/disassembler.scm b/module/system/vm/disassembler.scm index 08aa057a2..4db4a033d 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) @@ -80,70 +81,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 AU32 BU32 AS32 BS32 AF32 BF32) + #'(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* ...) @@ -204,8 +193,13 @@ 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-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) @@ -216,6 +210,7 @@ address of that offset." ((13) "vector?") ((15) "string?") ((53) "keyword?") + ((#x3d) "syntax?") ((77) "bytevector?") ((95) "bitvector?") (else (number->string tc7))))) @@ -230,7 +225,17 @@ 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)) + (('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) (list "~a arg~:p" nargs)) (('make-closure dst target nfree) @@ -296,8 +301,11 @@ 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-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest) + 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-<-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")))) @@ -515,7 +523,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)) @@ -548,15 +556,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))) @@ -564,26 +627,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 ac5fbf6f5..b699590f6 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-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,25 +25,35 @@ #: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 binding-name binding-slot + binding-representation 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)) +(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) + (make-binding frame idx name slot representation) binding? + (frame binding-frame) (idx binding-index) (name binding-name) - (slot binding-slot)) + (slot binding-slot) + (representation binding-representation)) (define (parse-code code) (let ((len (bytevector-length code))) @@ -83,6 +93,52 @@ (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 + ((= n (vector-length parsed)) + ;; Possible for jumps to alternate arities. + #f) + ((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) @@ -90,7 +146,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 @@ -103,7 +159,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) @@ -112,14 +168,17 @@ (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)) (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)) @@ -132,7 +191,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,11 +206,12 @@ (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)) -(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)) @@ -206,7 +266,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 @@ -223,10 +286,8 @@ (let ((n (bit-position #t live n))) (if n (match (vector-ref defs n) - (#(name def-offset slot) - ;; Binding 0 is the closure, and is not present - ;; in arity-definitions. - (cons (make-binding (1+ n) name slot) + (#(name def-offset slot representation) + (cons (make-binding frame n name slot representation) (lp (1+ n))))) '())))) (lp (1+ n) (- offset (vector-ref parsed n))))))) @@ -236,7 +297,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) @@ -248,19 +309,40 @@ (else (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)) +(define (binding-ref binding) + (frame-local-ref (or (binding-frame binding) + (error "binding has no frame" binding)) + (binding-slot binding) + (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))))) +(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 + (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 @@ -268,6 +350,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))) ;;; @@ -292,20 +384,33 @@ (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 (and (< i nlocals) i)) (() #f) - ((($ idx name slot) . bindings) + (((and binding ($ frame 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) + (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) @@ -333,22 +438,21 @@ (else '()))) (cons - (or (and=> info program-debug-info-name) - (and (procedure? closure) (procedure-name closure)) - closure) + (or (frame-procedure-name frame #:info info) '_) (cond ((find-program-arity ip) => (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)))) - ((and (primitive? closure) - (program-arguments-alist closure ip)) + (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) (match args ((('required . req) @@ -368,12 +472,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) diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm index 8151462d5..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 @@ -394,12 +429,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 @@ -633,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) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 59cb8c019..32c96f26a 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)) @@ -270,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))) diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index ca6acddfa..c4861c925 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -110,27 +110,30 @@ ;; 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 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 +163,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 +219,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 +265,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 +377,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 +425,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 +463,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 +504,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 () 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/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/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 diff --git a/module/web/client.scm b/module/web/client.scm index 11fee352d..3b7ea5156 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, 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 @@ -43,6 +43,8 @@ #: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 http-get @@ -54,21 +56,124 @@ 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 (ensure-uri uri-or-string) +(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) + ;; 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-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 (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)) + (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))) + (setvbuf record 'block) + (make-custom-binary-input/output-port "gnutls wrapped port" read! write! + get-position set-position! + close)))) + +(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 @@ -81,27 +186,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 _IOFBF) - ;; 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 'block %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) @@ -213,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 a157cf021..993b50ef4 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-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 @@ -34,8 +34,10 @@ #: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 (ice-9 textual-ports) #:use-module (rnrs bytevectors) #:use-module (web uri) #:export (string->header @@ -72,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))) @@ -97,11 +105,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." @@ -137,35 +145,34 @@ 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-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-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-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)))) - 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)) @@ -176,7 +183,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*) @@ -199,17 +206,17 @@ 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 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 @@ -225,10 +232,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))))) @@ -262,7 +271,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]")) @@ -271,9 +280,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)) @@ -300,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))) @@ -309,81 +318,84 @@ as an ordered alist." (list-of? val symbol?)) (define (write-header-list val port) - (write-list val port - (lambda (x port) - (display (header->string x) port)) - ", ")) + (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))) (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 (put-list port items put-item delim) + (match items + (() (values)) + ((item . items) + (put-item port item) + (let lp ((items items)) + (match items + (() (values)) + ((item . items) + (put-string port delim) + (put-item port item) + (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-list port (string-split str #\") put-string "\\\"") + (put-string port str)) + (put-char port #\")) (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)) @@ -418,17 +430,16 @@ 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) - (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,47 +447,44 @@ 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 - (lambda (x port) - (let ((q (car x)) - (str (cdr x))) - (display str port) - (if (< q 1000) - (begin - (display ";q=" port) - (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))) (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))) @@ -492,14 +500,14 @@ 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) (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 +528,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))))) + (put-list + port list + (lambda (port x) + (match x + ((k . #f) + (put-symbol port k)) + ((k . v) + (put-symbol port k) + (put-char port #\=) + (val-writer k v port)) + (k + (put-symbol port k)))) delim)) ;; param-component = token [ "=" (token | quoted-string) ] \ @@ -625,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 ";")) ",")) @@ -751,6 +757,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))) @@ -762,8 +788,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)) @@ -783,8 +809,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) @@ -815,76 +841,96 @@ 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)))) - (if (> tens 0) - (begin - (display (integer->char (+ zero (modulo (truncate/ n tens) 10))) - port) - (lp (floor/ tens 10)))))) + (when (> tens 0) + (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) - (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) - (display-digits (date-year date) 4 port) - (display #\space port) - (display-digits (date-hour date) 2 port) - (display #\: port) - (display-digits (date-minute date) 2 port) - (display #\: port) - (display-digits (date-second date) 2 port) - (display " GMT" 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)))) + (put-digits port (date-day date) 2) + (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)))) + (put-digits port (date-year date) 4) + (put-char port #\space) + (put-digits port (date-hour date) 2) + (put-char port #\:) + (put-digits port (date-minute date) 2) + (put-char port #\:) + (put-digits port (date-second date) 2) + (put-string port " GMT"))) -(define (parse-entity-tag val) - (if (string-prefix? "W/" val) - (cons (parse-qstring val 2) #f) - (cons (parse-qstring val) #t))) +;; 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 #: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 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) - (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)) +(define (put-entity-tag port val) + (match val + ((tag . strong?) + (unless strong? (put-string port "W/")) + (write-qstring tag port)))) (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?)) -(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 @@ -897,31 +943,34 @@ 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) - (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 @@ -962,34 +1011,35 @@ 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) - (display #\space port) - (write-key-value-list (cdr val) port)) +(define (put-challenge port val) + (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 ", ")) + (put-list port val put-challenge ", ")) @@ -1010,25 +1060,28 @@ 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." - (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) @@ -1059,20 +1112,21 @@ 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")) ((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))) - (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)))))) @@ -1080,97 +1134,74 @@ 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)) - (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) - (when (uri-scheme uri) - (display (uri-scheme uri) port) - (display #\: port)) - (display "//" port) - (when (uri-userinfo uri) - (display (uri-userinfo uri) port) - (display #\@ port)) - (display (uri-host uri) port) - (let ((p (uri-port uri))) - (when (and p (not (eqv? p 80))) - (display #\: port) - (display p port)))) - (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 - (display path port)))) - (when (uri-query uri) - (display #\? port) - (display (uri-query uri) port))) + (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." - (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) - (if (string-index host #\:) - (begin (display #\[ port) - (display host port) - (display #\] port)) - (display host port)) + (put-symbol port scheme) + (put-string port "://") + (cond + ((host string-index #\:) + (put-char #\[ port) + (put-string port host + (put-char port #\]))) + (else + (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)) - (if query - (begin - (display "?" port) - (display query port)))) - (display #\space port) + (put-string port "/") + (put-string port path)) + (when query + (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 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))))) - (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." (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")) @@ -1205,7 +1236,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) @@ -1215,22 +1246,16 @@ 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)) - -;; 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)) + parse-non-negative-integer non-negative-integer? + (lambda (val port) (put-non-negative-integer port val)))) ;; 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) @@ -1265,8 +1290,8 @@ 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) - (write-entity-tag-list val port))))) + (put-string port "*") + (put-entity-tag-list port val))))) ;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1) (define (declare-credentials-header! name) @@ -1335,11 +1360,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))))) @@ -1352,13 +1377,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) - (display (if (eq? x 'close) - "close" - (header->string x)) - port)) - ", "))) + (put-list port val + (lambda (port x) + (put-string port + (if (eq? x 'close) + "close" + (header->string x)))) + ", "))) ;; Date = "Date" ":" HTTP-date ;; e.g. @@ -1414,59 +1439,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) - (display code port) - (display #\space port) - (display host port) - (display #\space port) + (put-list + port val + (lambda (port w) + (match w + ((code host text date) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port host) + (put-char port #\space) (write-qstring text port) - (if date - (begin - (display #\space port) - (write-date date port)))) - w)) + (when date + (put-char port #\space) + (put-char port #\") + (write-date date port) + (put-char port #\"))))) ", ")) #:multiple? #t) @@ -1490,18 +1514,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))) @@ -1538,44 +1558,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) - (display #\- port) - (display (caadr val) port))) - (if (eq? (caddr val) '*) - (display #\* port) - (display (caddr val) port)))) + (match val + ((unit range instance-length) + (put-symbol port unit) + (put-char port #\space) + (match range + ('* + (put-char port #\*)) + ((start . end) + (put-non-negative-integer port start) + (put-char port #\-) + (put-non-negative-integer port end))) + (put-char port #\/) + (match instance-length + ('* (put-char port #\*)) + (len (put-non-negative-integer port len))))))) ;; Content-Type = media-type ;; @@ -1585,31 +1605,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 - (display ";" port) - (write-list - (cdr val) port - (lambda (pair port) - (display (car pair) port) - (display #\= port) - (display (cdr pair) port)) - ";"))))) + (match val + ((type . args) + (put-symbol port type) + (match args + (() (values)) + (args + (put-string port ";") + (put-list + port args + (lambda (port pair) + (match pair + ((k . v) + (put-symbol port k) + (put-char port #\=) + (put-string port v)))) + ";"))))))) ;; Expires = HTTP-date ;; @@ -1713,21 +1736,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 #\:) + (put-char port #\[) + (put-string port host-name) + (put-char port #\])) + (else + (put-string port host-name))) + (when host-port + (put-char port #\:) + (put-non-negative-integer port host-port)))))) ;; If-Match = ( "*" | 1#entity-tag ) ;; @@ -1754,7 +1778,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 ;; @@ -1780,45 +1804,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) + (put-symbol port unit) + (put-char port #\=) + (put-list + port ranges + (lambda (port range) + (match range + ((start . end) + (when start (put-non-negative-integer port start)) + (put-char port #\-) + (when end (put-non-negative-integer port end))))) + ","))))) ;; Referer = URI-reference ;; @@ -1855,7 +1879,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 ;; @@ -1882,7 +1907,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 ) ;; @@ -1899,7 +1924,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 @@ -1909,24 +1934,21 @@ treated specially, and is just returned as a plain string." ;; Chunked Responses (define (read-chunk-header port) - (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)) - -(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)) + "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 @@ -1934,54 +1956,65 @@ 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) + (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))) + (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)) -(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)) (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) @@ -1989,18 +2022,20 @@ 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) - (q-for-each (lambda (elem) (write-char elem port)) + (put-string port (number->string len 16)) + (put-string port "\r\n") + (q-for-each (lambda (elem) (put-char port elem)) 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))) - (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)) diff --git a/module/web/request.scm b/module/web/request.scm index 0a206cf35..eea32e9ce 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) @@ -169,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)) @@ -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 58e3f1141..06e1c6dc1 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 @@ -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) @@ -265,7 +266,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/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 cda44f4aa..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) @@ -97,7 +98,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/module/web/uri.scm b/module/web/uri.scm index e1c8b3998..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) "")))) @@ -322,7 +416,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 +432,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 +446,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 +529,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/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/Makefile.am b/prebuilt/Makefile.am new file mode 100644 index 000000000..5753e09f4 --- /dev/null +++ b/prebuilt/Makefile.am @@ -0,0 +1,61 @@ +## 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 + +EXTRA_DIST = \ + 32-bit-big-endian \ + 32-bit-little-endian \ + 64-bit-little-endian diff --git a/prebuilt/i686-pc-linux-gnu/Makefile.am b/prebuilt/i686-pc-linux-gnu/Makefile.am new file mode 100644 index 000000000..327002b60 --- /dev/null +++ b/prebuilt/i686-pc-linux-gnu/Makefile.am @@ -0,0 +1,27 @@ +## 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 + +EXTRA_DIST = $(GOBJECTS) diff --git a/prebuilt/mips-unknown-linux-gnu/Makefile.am b/prebuilt/mips-unknown-linux-gnu/Makefile.am new file mode 100644 index 000000000..327002b60 --- /dev/null +++ b/prebuilt/mips-unknown-linux-gnu/Makefile.am @@ -0,0 +1,27 @@ +## 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 + +EXTRA_DIST = $(GOBJECTS) 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..327002b60 --- /dev/null +++ b/prebuilt/x86_64-unknown-linux-gnu/Makefile.am @@ -0,0 +1,27 @@ +## 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 + +EXTRA_DIST = $(GOBJECTS) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 41c5549cc..bbf41b673 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -23,10 +23,10 @@ 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 \ - tests/arbiters.test \ tests/arrays.test \ tests/bit-operations.test \ tests/bitvectors.test \ @@ -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 \ @@ -115,7 +116,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/r6rs-records-syntactic.test \ tests/r6rs-unicode.test \ tests/rnrs-libraries.test \ - tests/ramap.test \ + tests/array-map.test \ tests/random.test \ tests/rdelim.test \ tests/reader.test \ @@ -124,11 +125,13 @@ 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 \ tests/srcprop.test \ tests/srfi-1.test \ + tests/srfi-2.test \ tests/srfi-6.test \ tests/srfi-10.test \ tests/srfi-11.test \ @@ -163,6 +166,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 \ @@ -174,6 +178,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/guile-test b/test-suite/guile-test index 4a264b426..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 @@ -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))) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 5138b1549..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. @@ -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-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/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"< + (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-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c index f4cd53d84..453c53ce8 100644 --- a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c +++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c @@ -94,30 +94,27 @@ 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"))); @@ -214,10 +211,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/standalone/test-scm-c-read.c b/test-suite/standalone/test-scm-c-read.c index 5f11e7565..c4dbf6251 100644 --- a/test-suite/standalone/test-scm-c-read.c +++ b/test-suite/standalone/test-scm-c-read.c @@ -33,52 +33,41 @@ /* 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) +make_port (scm_t_port_type *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 size_t +custom_port_read (SCM port, SCM dst, size_t start, size_t count) { - int result; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); + size_t to_copy = count; + 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++; + memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start, + stream->buf + stream->pos, to_copy); + stream->pos += to_copy; - return result; + return to_copy; } /* Return true (non-zero) if BUF contains only zeros. */ @@ -99,11 +88,11 @@ 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; - 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/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; +} diff --git a/test-suite/standalone/test-stack-overflow b/test-suite/standalone/test-stack-overflow index 3b979a99e..dd54249d8 100755 --- a/test-suite/standalone/test-stack-overflow +++ b/test-suite/standalone/test-stack-overflow @@ -9,6 +9,26 @@ 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-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 + ;; 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)) @@ -28,6 +48,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) 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 diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test new file mode 100644 index 000000000..54f518a66 --- /dev/null +++ b/test-suite/tests/00-repl-server.test @@ -0,0 +1,152 @@ +;;;; 00-repl-server.test --- REPL server. -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; 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 +;;;; 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))) + + ;; The REPL server requires thread. The test requires fork. + (unless (and (provided? 'threads) (provided? 'fork)) + (throw 'unsupported)) + + (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 + (sigaction SIGPIPE SIG_IGN) + (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 (memv (system-error-errno args) + (list ENOENT ECONNREFUSED)) + (when (> tries 30) + (throw 'unresolved)) + (usleep 100) + (loop (+ tries 1)))))) + + (proc client-socket)) + (lambda () + (false-if-exception (close-port client-socket)) + (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 +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) + + ;; 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 + ;; 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 ECONNABORTED)))))))) + +;;; Local Variables: +;;; eval: (put 'with-repl-server 'scheme-indent-function 1) +;;; End: 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/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)) 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)) 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))))) diff --git a/test-suite/tests/ramap.test b/test-suite/tests/array-map.test similarity index 93% rename from test-suite/tests/ramap.test rename to test-suite/tests/array-map.test index c8eaf96eb..347184112 100644 --- a/test-suite/tests/ramap.test +++ b/test-suite/tests/array-map.test @@ -1,4 +1,4 @@ -;;;; ramap.test --- test array mapping functions -*- scheme -*- +;;;; array-map.test --- test array mapping functions -*- scheme -*- ;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc. ;;;; @@ -16,7 +16,7 @@ ;;;; 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-ramap) +(define-module (test-suite test-array-map) #:use-module (test-suite lib)) (define exception:shape-mismatch @@ -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" @@ -507,3 +507,34 @@ (b (make-typed-array 'f64 0 0 2)) (c (make-typed-array 'f64 0 2 0))) (array-for-each (lambda (b c) (set! a (cons* b c a))) b c))))) + +;;; +;;; array-slice-for-each +;;; + +(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-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-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-slice-for-each 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))) diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index e76c699e9..1df77b1ba 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?" @@ -204,15 +217,18 @@ (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 ;;; -(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 @@ -280,6 +296,115 @@ (and (eqv? 5 (array-ref s2 1)) (eqv? 8 (array-ref s2 2)))))) + +;;; +;;; array-slice +;;; + +(with-test-prefix/c&e "array-slice" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (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-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-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-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-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-slice a) 'a) + (array-equal? a #0(a))))) + + +;;; +;;; array-cell-ref +;;; + +(with-test-prefix/c&e "array-cell-ref" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (equal? 2 (array-cell-ref v 1)))) + + (pass-if "vector II" + (let ((v (vector 1 2 3))) + (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-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-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-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-cell-ref a) 77)))) + + +;;; +;;; array-cell-set! +;;; + +(with-test-prefix/c&e "array-cell-set!" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (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-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-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-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-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-cell-set! a 99)) + (array-equal? a #0(99)))))) + + ;;; ;;; array-contents ;;; @@ -288,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)))) @@ -391,14 +522,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 "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 @@ -535,7 +710,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))))) @@ -546,7 +721,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)))) @@ -809,10 +984,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))) diff --git a/test-suite/tests/asyncs.test b/test-suite/tests/asyncs.test new file mode 100644 index 000000000..4ac9020c4 --- /dev/null +++ b/test-suite/tests/asyncs.test @@ -0,0 +1,139 @@ +;;;; asyncs.test -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; 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 +;;;; 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 (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)) + (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))))) diff --git a/test-suite/tests/atomic.test b/test-suite/tests/atomic.test new file mode 100644 index 000000000..8fc8ba9d3 --- /dev/null +++ b/test-suite/tests/atomic.test @@ -0,0 +1,60 @@ +;;;; 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)) + +(with-test-prefix/c&e "atomics" + (pass-if "predicate" (atomic-box? (make-atomic-box 42))) + + (pass-if-equal "ref" 42 (atomic-box-ref (make-atomic-box 42))) + + (pass-if-equal "swap" 42 (atomic-box-swap! (make-atomic-box 42) 10)) + + (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 "swap and ref" 10 + (let ((box (make-atomic-box 42))) + (atomic-box-swap! box 10) + (atomic-box-ref box))) + + (pass-if-equal "compare and swap" 42 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 42 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 "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 "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" + (class-of (make-atomic-box 42)))) diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 4cc5b67e0..f0d9f1983 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. @@ -340,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" @@ -501,6 +508,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")) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 02f2a54c7..4f644f339 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -202,3 +202,52 @@ (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))) + + (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))) + +(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))) diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test index 52ce6b138..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" @@ -410,3 +420,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)))))) 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" 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)) 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)) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index e1837fd38..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)))) @@ -365,8 +370,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))) 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)))) 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")) 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..a5ca8857e 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 @@ -183,3 +184,86 @@ (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))))) + + (pass-if "exception handler not captured" + (let ((state (catch #t (lambda () (current-dynamic-state)) error))) + (catch #t + (lambda () (with-dynamic-state state (lambda () (/ 1 0)))) + (lambda _ #t))))) 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) diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index cc31942cc..b9aa7a854 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 @@ -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 @@ -134,12 +143,12 @@ (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/goops.test b/test-suite/tests/goops.test index 087b6a90a..6c6660478 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" @@ -562,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 () @@ -680,3 +699,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)))) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index c63e3ac5b..a20651120 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, 2016, 2017 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,34 +95,34 @@ (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") + "en_US.utf8") (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 @@ -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))) @@ -270,6 +271,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-localelocale-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.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))) (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 "negative integer" + "-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 -1234567 #t fr))))) - (pass-if "fraction, 1 digit" + (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,5" - (number->locale-string 1234.567 1 fr)))))))) + (number->locale-string 1234.567 #t fr))))) + + (pass-if-equal "fraction, 1 digit" + "1 234,6" + (under-french-locale-or-unresolved + (lambda () + (let ((fr (make-locale LC_ALL %french-locale-name))) + (number->locale-string 1234.567 1 fr))))))) (with-test-prefix "format ~h" @@ -520,39 +636,60 @@ (with-test-prefix "French" - (pass-if "12345.5678" + (pass-if-equal "12345.678" + "12 345,678" (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.678 %french-locale)))))) (with-test-prefix "English" - (pass-if "12345.5678" + (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) - (string=? "12,345.6789" - (format #f "~:h" 12345.6789 - %american-english-locale)))))))) + (format #f "~:h" 12345.678 + %american-english-locale))))))) (with-test-prefix "monetary-amount->locale-string" (with-test-prefix "French" - (pass-if "integer" + (pass-if-equal "integer" + "123 456,00 +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,57 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-equal "positive inexact zero" + "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))))) + + (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))))))) 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/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))))) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 847f93962..a0403a118 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 @@ -5424,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)))) 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 () diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 93988af14..4e2ccf9c6 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 @@ -1354,8 +1354,18 @@ (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 + (eq? '(a b) '(a b)) + (const #t)) + + (pass-if-peval + (eqv? '(a b) '(a b)) + (const #t)) (pass-if-peval ((lambda (foo) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index c43801db4..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 @@ -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. @@ -637,8 +636,10 @@ (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" + (unless (provided? 'fork) + (throw 'unresolved)) (let ((in+out (pipe)) (pid (primitive-fork))) (if (zero? pid) @@ -647,7 +648,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) @@ -736,6 +737,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 ‘ĉ’. @@ -822,21 +862,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 #\xFFFD) + (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)))) + (eqv? (proc port) #\xFFFD) + (decoding-error? port proc))) ((_ port (proc -> eof)) (eof-object? (proc port))) ((_ port (proc -> char)) @@ -1519,13 +1570,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 +1591,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*) @@ -1855,14 +1906,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 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)))) ;; diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test index 6ef0e9fc7..82cc77603 100644 --- a/test-suite/tests/print.test +++ b/test-suite/tests/print.test @@ -145,4 +145,46 @@ (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 "#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")) + + (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")) + + (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"))) 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))) diff --git a/test-suite/tests/r6rs-hashtables.test b/test-suite/tests/r6rs-hashtables.test index c7812c5b3..e2cbc2afc 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" @@ -174,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" diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index dd4092512..ba3131f2e 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))) @@ -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 @@ -516,7 +538,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 +567,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 +590,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 +605,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 +625,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 +657,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) @@ -694,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" @@ -705,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))) @@ -716,6 +771,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))) @@ -789,6 +852,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,10 +877,28 @@ 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)))) + (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)))) @@ -873,6 +955,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) #\λ) @@ -991,11 +1074,526 @@ 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 . "")) + +(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 diff --git a/test-suite/tests/rdelim.test b/test-suite/tests/rdelim.test index 617e65167..3aaa0b253 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))))))) @@ -88,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)))))) 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 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:)))) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index 082e44fa9..316f4557c 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 @@ -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-values 2) (end-arity) (end-program)))) @@ -77,20 +77,30 @@ 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 ((name . foo))) (begin-standard-arity () 2 #f) - (load-static-procedure 1 bar) - (return 1) + (load-static-procedure 0 bar) + (return-values 2) (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-values 2) (end-arity) (end-program))))))) @@ -104,19 +114,21 @@ a procedure." '((begin-program countdown ((name . countdown))) (begin-standard-arity (x) 4 #f) - (definition x 1) + (definition closure 0 scm) + (definition x 1 scm) (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) + (add/immediate 1 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) + (mov 2 0) + (return-values 2) (end-arity) (end-program))))) (sumto 1000)))) @@ -133,20 +145,23 @@ 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) + (mov 1 0) + (return-values 2) (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) + (definition closure 0 scm) + (definition x 1 scm) + (free-ref 1 3 0) + (box-ref 0 1) + (add 0 0 2) + (box-set! 1 0) + (mov 2 0) + (return-values 2) (end-arity) (end-program))))) (let ((accum (make-accum))) @@ -161,11 +176,12 @@ a procedure." '((begin-program call ((name . call))) (begin-standard-arity (f) 7 #f) - (definition f 1) - (mov 5 1) + (definition closure 0 scm) + (definition f 1 scm) + (mov 1 5) (call 5 1) - (receive 2 5 7) - (return 2) + (receive 1 5 7) + (return-values 2) (end-arity) (end-program))))) (call (lambda () 42)))) @@ -176,12 +192,13 @@ a procedure." '((begin-program call-with-3 ((name . call-with-3))) (begin-standard-arity (f) 7 #f) - (definition f 1) - (mov 5 1) - (load-constant 6 3) + (definition closure 0 scm) + (definition f 1 scm) + (mov 1 5) + (load-constant 0 3) (call 5 2) - (receive 2 5 7) - (return 2) + (receive 1 5 7) + (return-values 2) (end-arity) (end-program))))) (call-with-3 (lambda (x) (* x 2)))))) @@ -193,8 +210,9 @@ a procedure." '((begin-program call ((name . call))) (begin-standard-arity (f) 2 #f) - (definition f 1) - (mov 0 1) + (definition closure 0 scm) + (definition f 1 scm) + (mov 1 0) (tail-call 1) (end-arity) (end-program))))) @@ -206,9 +224,10 @@ a procedure." '((begin-program call-with-3 ((name . call-with-3))) (begin-standard-arity (f) 2 #f) - (definition f 1) - (mov 0 1) ;; R0 <- R1 - (load-constant 1 3) ;; R1 <- 3 + (definition closure 0 scm) + (definition f 1 scm) + (mov 1 0) ;; R0 <- R1 + (load-constant 0 3) ;; R1 <- 3 (tail-call 2) (end-arity) (end-program))))) @@ -221,19 +240,20 @@ 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-values 2) (end-arity) (end-program) (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) - (definition x 1) - (cached-toplevel-box 2 sqrt-scope sqrt #t) - (box-ref 0 2) + (definition closure 0 scm) + (definition x 1 scm) + (cached-toplevel-box 0 sqrt-scope sqrt #t) + (box-ref 2 0) (tail-call 2) (end-arity) (end-program))))) @@ -249,10 +269,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-values 2) (end-arity) (end-program) @@ -260,11 +280,10 @@ 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) - (reset-frame 1) - (return-values) + (box-ref 0 1) + (add/immediate 0 0 1) + (box-set! 1 0) + (return-values 1) (end-arity) (end-program))))) ((make-top-incrementor)) @@ -277,17 +296,18 @@ 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-values 2) (end-arity) (end-program) (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) - (definition x 1) - (cached-module-box 2 (guile) sqrt #t #t) - (box-ref 0 2) + (definition closure 0 scm) + (definition x 1 scm) + (cached-module-box 0 (guile) sqrt #t #t) + (box-ref 2 0) (tail-call 2) (end-arity) (end-program))))) @@ -301,8 +321,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-values 2) (end-arity) (end-program) @@ -310,10 +330,11 @@ 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) + (add/immediate 0 0 1) + (box-set! 1 0) + (mov 1 0) + (return-values 2) (end-arity) (end-program))))) ((make-top-incrementor)) @@ -323,8 +344,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-values 2) (end-arity) (end-program))))) (pass-if "program name" @@ -345,8 +366,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-values 2) (end-arity) (end-program)))))) @@ -356,8 +377,9 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (definition closure 0 scm) + (load-constant 0 42) + (return-values 2) (end-arity) (end-program))))) (pass-if-equal "#" @@ -365,10 +387,11 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity (x y) 3 #f) - (definition x 1) - (definition y 2) + (definition closure 0 scm) + (definition x 1 scm) + (definition y 2 scm) (load-constant 1 42) - (return 1) + (return-values 2) (end-arity) (end-program))))) @@ -377,11 +400,12 @@ 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) - (load-constant 1 42) - (return 1) + (definition closure 0 scm) + (definition x 1 scm) + (definition y 2 scm) + (definition z 3 scm) + (load-constant 2 42) + (return-values 2) (end-arity) (end-program)))))) @@ -391,8 +415,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 +427,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 +439,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 +454,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 +467,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)))))) 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))))) + 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/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 '#() <)))) - diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index ab055132e..a6e184c6f 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 @@ -301,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)) @@ -375,7 +411,9 @@ (mutex-unlock! m1))) (dec-sem! (lambda () (mutex-lock! m1) - (while (eqv? sem 0) (wait-condition-variable c1 m1)) + (while (eqv? sem 0) + (mutex-unlock! m1 c1) + (mutex-lock! m1)) (set! sem (- sem 1)) (mutex-unlock! m1))) (t1 (make-thread (lambda () @@ -449,13 +487,15 @@ h2 (lambda () (mutex-lock! m) (condition-variable-signal! c) - (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) - (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) @@ -482,7 +522,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))))) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index d63e62222..c963f15c9 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 @@ -175,6 +175,19 @@ 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")))) + + (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)) 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 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 diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test index b799f58d3..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,22 +42,24 @@ (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)))))) (pass-if-equal "return values" '(42 77) - (call-with-values - (lambda () - (with-output-to-port (%make-void-port "w") - (lambda () - (with-statprof + (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)) + (loop (1- i))))))))) + list))) (pass-if "statistical sample counts within expected range" (when-implemented @@ -123,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) @@ -134,7 +137,7 @@ (loop (- x 1)) #t))) (statprof-stop) - + ;; Check result. (let ((proc-data (statprof-proc-call-data do-nothing))) (and proc-data diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 56c898c8b..b404253ce 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 @@ -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" @@ -457,6 +475,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 ;; diff --git a/test-suite/tests/suspendable-ports.test b/test-suite/tests/suspendable-ports.test new file mode 100644 index 000000000..28557d5f5 --- /dev/null +++ b/test-suite/tests/suspendable-ports.test @@ -0,0 +1,58 @@ +;;;; 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 suspendable-ports)) + +;; 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)))))))) + #:guess-encoding #t))))) + +(install-suspendable-ports!) + +(include-tests "tests/ports.test") +(include-tests "tests/rdelim.test") +(include-tests "tests/r6rs-ports.test") + +(uninstall-suspendable-ports!) 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) diff --git a/module/language/cps2/spec.scm b/test-suite/tests/texinfo.html.test similarity index 56% rename from module/language/cps2/spec.scm rename to test-suite/tests/texinfo.html.test index 5ab30ff6b..02f4d28c3 100644 --- a/module/language/cps2/spec.scm +++ b/test-suite/tests/texinfo.html.test @@ -1,37 +1,36 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2015 Free Software Foundation, Inc. - +;;;; 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 (language cps2 spec) - #:use-module (system base language) - #:use-module (language cps2) - #:use-module (language cps2 compile-cps) - #:export (cps2)) +(define-module (test-suite texinfo-html) + #:use-module (test-suite lib) + #:use-module (texinfo) + #:use-module (texinfo html)) -(define* (write-cps exp #:optional (port (current-output-port))) - (write (unparse-cps exp) port)) +(define (texi-fragment->shtml str) + (stexi->shtml (texi-fragment->stexi str))) -(define-language cps2 - #:title "CPS2 Intermediate Language" - #:reader (lambda (port env) (read port)) - #:printer write-cps - #:parser parse-cps - #:compilers `((cps . ,compile-cps)) - #:for-humans? #f - ) +(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")) 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}) +") ) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 3b7a3e440..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) @@ -351,13 +349,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 +362,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 @@ -403,18 +380,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)) @@ -453,11 +419,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) @@ -468,15 +430,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)))))))) ;; 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) 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 diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index dfc9677cf..63377349c 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; -*- +;;;; web-http.test --- HTTP library -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2014 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 @@ -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) @@ -38,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) @@ -46,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) @@ -132,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 @@ -170,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 @@ -179,16 +198,25 @@ (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" + (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" - (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" @@ -226,6 +254,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") @@ -261,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)) @@ -311,6 +355,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" @@ -331,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")) @@ -343,12 +397,13 @@ (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" - (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" @@ -368,18 +423,78 @@ (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 (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 + "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 "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 '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)) + (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 '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)) + (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) + (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")) 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-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))) diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 4873d7f71..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,14 +627,33 @@ (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" (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")))