diff --git a/README b/README index 9993fcfaf..4950229df 100644 --- a/README +++ b/README @@ -61,6 +61,12 @@ Guile requires the following external packages: libltdl is used for loading extensions at run-time. It is available from http://www.gnu.org/software/libtool/ + - GNU libunistring + + libunistring is used for Unicode string operations, such as the + `utf*->string' procedures. It is available from + http://www.gnu.org/software/libunistring/ . + Special Instructions For Some Systems ===================================== diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index e65e8bcb2..dcadd5869 100644 --- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -1,4 +1,5 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \ + benchmarks/bytevectors.bm \ benchmarks/continuations.bm \ benchmarks/if.bm \ benchmarks/logand.bm \ diff --git a/benchmark-suite/benchmarks/bytevectors.bm b/benchmark-suite/benchmarks/bytevectors.bm new file mode 100644 index 000000000..9547a71df --- /dev/null +++ b/benchmark-suite/benchmarks/bytevectors.bm @@ -0,0 +1,99 @@ +;;; -*- mode: scheme; coding: latin-1; -*- +;;; R6RS Byte Vectors. +;;; +;;; Copyright 2009 Ludovic Courtès +;;; +;;; +;;; 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 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks bytevector) + :use-module (rnrs bytevector) + :use-module (srfi srfi-4) + :use-module (benchmark-suite lib)) + +(define bv (make-bytevector 16384)) + +(define %native-endianness + (native-endianness)) + +(define %foreign-endianness + (if (eq? (native-endianness) (endianness little)) + (endianness big) + (endianness little))) + +(define u8v (make-u8vector 16384)) +(define u16v (make-u16vector 8192)) +(define u32v (make-u32vector 4196)) +(define u64v (make-u64vector 2048)) + + +(with-benchmark-prefix "ref/set!" + + (benchmark "bytevector-u8-ref" 1000000 + (bytevector-u8-ref bv 0)) + + (benchmark "bytevector-u16-ref (foreign)" 1000000 + (bytevector-u16-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u16-ref (native)" 1000000 + (bytevector-u16-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u16-native-ref" 1000000 + (bytevector-u16-native-ref bv 0)) + + (benchmark "bytevector-u32-ref (foreign)" 1000000 + (bytevector-u32-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u32-ref (native)" 1000000 + (bytevector-u32-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u32-native-ref" 1000000 + (bytevector-u32-native-ref bv 0)) + + (benchmark "bytevector-u64-ref (foreign)" 1000000 + (bytevector-u64-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u64-ref (native)" 1000000 + (bytevector-u64-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u64-native-ref" 1000000 + (bytevector-u16-native-ref bv 0))) + + +(with-benchmark-prefix "lists" + + (benchmark "bytevector->u8-list" 2000 + (bytevector->u8-list bv)) + + (benchmark "bytevector->uint-list 16-bit" 2000 + (bytevector->uint-list bv (native-endianness) 2)) + + (benchmark "bytevector->uint-list 64-bit" 2000 + (bytevector->uint-list bv (native-endianness) 8))) + + +(with-benchmark-prefix "SRFI-4" ;; for comparison + + (benchmark "u8vector-ref" 1000000 + (u8vector-ref u8v 0)) + + (benchmark "u16vector-ref" 1000000 + (u16vector-ref u16v 0)) + + (benchmark "u32vector-ref" 1000000 + (u32vector-ref u32v 0)) + + (benchmark "u64vector-ref" 1000000 + (u64vector-ref u64v 0))) diff --git a/build-aux/config.rpath b/build-aux/config.rpath index 35f959b87..85c2f209b 100755 --- a/build-aux/config.rpath +++ b/build-aux/config.rpath @@ -47,7 +47,7 @@ for cc_temp in $CC""; do done cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'` -# Code taken from libtool.m4's AC_LIBTOOL_PROG_COMPILER_PIC. +# Code taken from libtool.m4's _LT_COMPILER_PIC. wl= if test "$GCC" = yes; then @@ -64,7 +64,7 @@ else ;; esac ;; - mingw* | cygwin* | pw32* | os2*) + mingw* | cygwin* | pw32* | os2* | cegcc*) ;; hpux9* | hpux10* | hpux11*) wl='-Wl,' @@ -76,7 +76,13 @@ else ;; linux* | k*bsd*-gnu) case $cc_basename in - icc* | ecc*) + ecc*) + wl='-Wl,' + ;; + icc* | ifort*) + wl='-Wl,' + ;; + lf95*) wl='-Wl,' ;; pgcc | pgf77 | pgf90) @@ -124,7 +130,7 @@ else esac fi -# Code taken from libtool.m4's AC_LIBTOOL_PROG_LD_SHLIBS. +# Code taken from libtool.m4's _LT_LINKER_SHLIBS. hardcode_libdir_flag_spec= hardcode_libdir_separator= @@ -132,7 +138,7 @@ hardcode_direct=no hardcode_minus_L=no case "$host_os" in - cygwin* | mingw* | pw32*) + cygwin* | mingw* | pw32* | cegcc*) # FIXME: the MSVC++ port hasn't been tested in a loooong time # When not using gcc, we currently assume that we are using # Microsoft Visual C++. @@ -182,7 +188,7 @@ if test "$with_gnu_ld" = yes; then ld_shlibs=no fi ;; - cygwin* | mingw* | pw32*) + cygwin* | mingw* | pw32* | cegcc*) # hardcode_libdir_flag_spec is actually meaningless, as there is # no search path for DLLs. hardcode_libdir_flag_spec='-L$libdir' @@ -326,7 +332,7 @@ else ;; bsdi[45]*) ;; - cygwin* | mingw* | pw32*) + cygwin* | mingw* | pw32* | cegcc*) # When not using gcc, we currently assume that we are using # Microsoft Visual C++. # hardcode_libdir_flag_spec is actually meaningless, as there is @@ -494,7 +500,7 @@ else fi # Check dynamic linker characteristics -# Code taken from libtool.m4's AC_LIBTOOL_SYS_DYNAMIC_LINKER. +# Code taken from libtool.m4's _LT_SYS_DYNAMIC_LINKER. # Unlike libtool.m4, here we don't care about _all_ names of the library, but # only about the one the linker finds when passed -lNAME. This is the last # element of library_names_spec in libtool.m4, or possibly two of them if the @@ -517,7 +523,7 @@ case "$host_os" in bsdi[45]*) library_names_spec='$libname$shrext' ;; - cygwin* | mingw* | pw32*) + cygwin* | mingw* | pw32* | cegcc*) shrext=.dll library_names_spec='$libname.dll.a $libname.lib' ;; diff --git a/configure.in b/configure.in index 07c476686..6568e524f 100644 --- a/configure.in +++ b/configure.in @@ -836,6 +836,13 @@ AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], [], [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])]) +dnl GNU libunistring tests. +if test "x$LTLIBUNISTRING" != "x"; then + LIBS="$LTLIBUNISTRING $LIBS" +else + AC_MSG_ERROR([GNU libunistring is required, please install it.]) +fi + dnl i18n tests #AC_CHECK_HEADERS([libintl.h]) #AC_CHECK_FUNCS(gettext) diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index e3cf25823..8098b4ffb 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -162,18 +162,10 @@ appropriate module first, though: Returns @code{#t} iff @var{obj} is a compiled procedure. @end deffn -@deffn {Scheme Procedure} program-bytecode program -@deffnx {C Function} scm_program_bytecode (program) -Returns the object code associated with this program, as a -@code{u8vector}. -@end deffn - -@deffn {Scheme Procedure} program-base program -@deffnx {C Function} scm_program_base (program) -Returns the address in memory corresponding to the start of -@var{program}'s object code, as an integer. This is useful mostly when -you map the value of an instruction pointer from the VM to actual -instructions. +@deffn {Scheme Procedure} program-objcode program +@deffnx {C Function} scm_program_objcode (program) +Returns the object code associated with this program. @xref{Bytecode +and Objcode}, for more information. @end deffn @deffn {Scheme Procedure} program-objects program @@ -184,9 +176,9 @@ vector. @xref{VM Programs}, for more information. @deffn {Scheme Procedure} program-module program @deffnx {C Function} scm_program_module (program) -Returns the module that was current when this program was created. -Free variables in this program are looked up with respect to this -module. +Returns the module that was current when this program was created. Can +return @code{#f} if the compiler could determine that this information +was unnecessary. @end deffn @deffn {Scheme Procedure} program-external program @@ -250,9 +242,9 @@ REPL. The only tricky bit is that @var{extp} is a boolean, declaring whether the binding is heap-allocated or not. @xref{VM Concepts}, for more information. -Note that bindings information are stored in a program as part of its -metadata thunk, so including them in the generated object code does -not impose a runtime performance penalty. +Note that bindings information is stored in a program as part of its +metadata thunk, so including it in the generated object code does not +impose a runtime performance penalty. @end deffn @deffn {Scheme Procedure} program-sources program diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 27d8f79c8..0d68abfc6 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -22,9 +22,10 @@ know how to compile your .scm file. @menu * Compiler Tower:: * The Scheme Compiler:: -* GHIL:: +* Tree-IL:: * GLIL:: -* Object Code:: +* Assembly:: +* Bytecode and Objcode:: * Extending the Compiler:: @end menu @@ -52,7 +53,7 @@ They are registered with the @code{define-language} form. @deffn {Scheme Syntax} define-language @ name title version reader printer @ -[parser=#f] [read-file=#f] [compilers='()] [evaluator=#f] +[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f] Define a language. This syntax defines a @code{#} object, bound to @var{name} @@ -62,17 +63,15 @@ for Scheme: @example (define-language scheme - #:title "Guile Scheme" - #:version "0.5" - #:reader read - #:read-file read-file - #:compilers `((,ghil . ,compile-ghil)) - #:evaluator (lambda (x module) (primitive-eval x)) - #:printer write) + #:title "Guile Scheme" + #:version "0.5" + #:reader read + #:compilers `((tree-il . ,compile-tree-il) + (ghil . ,compile-ghil)) + #:decompilers `((tree-il . ,decompile-tree-il)) + #:evaluator (lambda (x module) (primitive-eval x)) + #:printer write) @end example - -In this example, from @code{(language scheme spec)}, @code{read-file} -reads expressions from a port and wraps them in a @code{begin} block. @end deffn The interesting thing about having languages defined this way is that @@ -85,12 +84,12 @@ Guile Scheme interpreter 0.5 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -scheme@@(guile-user)> ,language ghil -Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0 +scheme@@(guile-user)> ,language tree-il +Tree Intermediate Language interpreter 1.0 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -ghil@@(guile-user)> +tree-il@@(guile-user)> @end example Languages can be looked up by name, as they were above. @@ -128,17 +127,25 @@ The normal tower of languages when compiling Scheme goes like this: @itemize @item Scheme, which we know and love -@item Guile High Intermediate Language (GHIL) +@item Tree Intermediate Language (Tree-IL) @item Guile Low Intermediate Language (GLIL) -@item Object code +@item Assembly +@item Bytecode +@item Objcode @end itemize Object code may be serialized to disk directly, though it has a cookie -and version prepended to the front. But when compiling Scheme at -run time, you want a Scheme value, e.g. a compiled procedure. For this -reason, so as not to break the abstraction, Guile defines a fake -language, @code{value}. Compiling to @code{value} loads the object -code into a procedure, and wakes the sleeping giant. +and version prepended to the front. But when compiling Scheme at run +time, you want a Scheme value: for example, a compiled procedure. For +this reason, so as not to break the abstraction, Guile defines a fake +language at the bottom of the tower: + +@itemize +@item Value +@end itemize + +Compiling to @code{value} loads the object code into a procedure, and +wakes the sleeping giant. Perhaps this strangeness can be explained by example: @code{compile-file} defaults to compiling to object code, because it @@ -156,340 +163,254 @@ different worlds indefinitely, as shown by the following quine: @node The Scheme Compiler @subsection The Scheme Compiler -The job of the Scheme compiler is to expand all macros and to resolve -all symbols to lexical variables. Its target language, GHIL, is fairly -close to Scheme itself, so this process is not very complicated. +The job of the Scheme compiler is to expand all macros and all of +Scheme to its most primitive expressions. The definition of +``primitive'' is given by the inventory of constructs provided by +Tree-IL, the target language of the Scheme compiler: procedure +applications, conditionals, lexical references, etc. This is described +more fully in the next section. -The Scheme compiler is driven by a table of @dfn{translators}, -declared with the @code{define-scheme-translator} form, defined in the -module, @code{(language scheme compile-ghil)}. +The tricky and amusing thing about the Scheme-to-Tree-IL compiler is +that it is completely implemented by the macro expander. Since the +macro expander has to run over all of the source code already in order +to expand macros, it might as well do the analysis at the same time, +producing Tree-IL expressions directly. -@deffn {Scheme Syntax} define-scheme-translator head clause1 clause2... -The best documentation of this form is probably an example. Here is -the translator for @code{if}: +Because this compiler is actually the macro expander, it is +extensible. Any macro which the user writes becomes part of the +compiler. -@example -(define-scheme-translator if - ;; (if TEST THEN [ELSE]) - ((,test ,then) - (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin)))) - ((,test ,then ,else) - (make-ghil-if e l (retrans test) (retrans then) (retrans else)))) -@end example +The Scheme-to-Tree-IL expander may be invoked using the generic +@code{compile} procedure: -The match syntax is from the @code{pmatch} macro, defined in -@code{(system base pmatch)}. The result of a clause should be a valid -GHIL value. If no clause matches, a syntax error is signalled. +@lisp +(compile '(+ 1 2) #:from 'scheme #:to 'tree-il) +@result{} + #< src: #f + proc: #< src: #f name: +> + args: (#< src: #f exp: 1> + #< src: #f exp: 2>)> +@end lisp -In the body of the clauses, the following bindings are introduced: -@itemize -@item @code{e}, the current environment -@item @code{l}, the current source location (or @code{#f}) -@item @code{retrans}, a procedure that may be called to compile -subexpressions -@end itemize +Or, since Tree-IL is so close to Scheme, it is often useful to expand +Scheme to Tree-IL, then translate back to Scheme. For that reason the +expander provides two interfaces. The former is equivalent to calling +@code{(sc-expand '(+ 1 2) 'c)}, where the @code{'c} is for +``compile''. With @code{'e} (the default), the result is translated +back to Scheme: -Note that translators are looked up by @emph{value}, not by name. That -is to say, the translator is keyed under the @emph{value} of -@code{if}, which normally prints as @code{#}. -@end deffn +@lisp +(sc-expand '(+ 1 2)) +@result{} (+ 1 2) +(sc-expand '(let ((x 10)) (* x x))) +@result{} (let ((x84 10)) (* x84 x84)) +@end lisp -Users can extend the compiler by defining new translators. -Additionally, some forms can be inlined directly to -instructions -- @xref{Inlined Scheme Instructions}, for a list. The -actual inliners are defined in @code{(language scheme inline)}: +The second example shows that as part of its job, the macro expander +renames lexically-bound variables. The original names are preserved +when compiling to Tree-IL, but can't be represented in Scheme: a +lexical binding only has one name. It is for this reason that the +@emph{native} output of the expander is @emph{not} Scheme. There's too +much information we would lose if we translated to Scheme directly: +lexical variable names, source locations, and module hygiene. -@deffn {Scheme Syntax} define-inline head arity1 result1 arity2 result2... -Defines an inliner for @code{head}. As in -@code{define-scheme-translator}, inliners are keyed by value and not -by name. +Note however that @code{sc-expand} does not have the same signature as +@code{compile-tree-il}. @code{compile-tree-il} is a small wrapper +around @code{sc-expand}, to make it conform to the general form of +compiler procedures in Guile's language tower. -Expressions are matched on their arities. For example: +Compiler procedures take two arguments, an expression and an +environment. They return three values: the compiled expression, the +corresponding environment for the target language, and a +``continuation environment''. The compiled expression and environment +will serve as input to the next language's compiler. The +``continuation environment'' can be used to compile another expression +from the same source language within the same module. -@example -(define-inline eq? - (x y) (eq? x y)) -@end example +For example, you might compile the expression, @code{(define-module +(foo))}. This will result in a Tree-IL expression and environment. But +if you compiled a second expression, you would want to take into +account the compile-time effect of compiling the previous expression, +which puts the user in the @code{(foo)} module. That is purpose of the +``continuation environment''; you would pass it as the environment +when compiling the subsequent expression. -This inlines calls to the Scheme procedure, @code{eq?}, to the -instruction @code{eq?}. - -A more complicated example would be: - -@example -(define-inline + - () 0 - (x) x - (x y) (add x y) - (x y . rest) (add x (+ y . rest))) -@end example -@end deffn - -Compilers take two arguments, an expression and an environment, and -return two values as well: an expression in the target language, and -an environment suitable for the target language. The format of the -environment is language-dependent. - -For Scheme, an environment may be one of three things: +For Scheme, an environment may be one of two things: @itemize @item @code{#f}, in which case compilation is performed in the context -of the current module; -@item a module, which specifies the context of the compilation; or -@item a @dfn{compile environment}, which specifies lexical variables -as well. +of the current module; or +@item a module, which specifies the context of the compilation. @end itemize -The format of a compile environment for scheme is @code{(@var{module} -@var{lexicals} . @var{externals})}, though users are strongly -discouraged from constructing these environments themselves. Instead, -if you need this functionality -- as in GOOPS' dynamic method compiler --- capture an environment with @code{compile-time-environment}, then -pass that environment to @code{compile}. +@node Tree-IL +@subsection Tree-IL -@deffn {Scheme Procedure} compile-time-environment -A special function known to the compiler that, when compiled, will -return a representation of the lexical environment in place at compile -time. Useful for supporting some forms of dynamic compilation. Returns -@code{#f} if called from the interpreter. -@end deffn - -@node GHIL -@subsection GHIL - -Guile High Intermediate Language (GHIL) is a structured intermediate +Tree Intermediate Language (Tree-IL) is a structured intermediate language that is close in expressive power to Scheme. It is an expanded, pre-analyzed Scheme. -GHIL is ``structured'' in the sense that its representation is based -on records, not S-expressions. This gives a rigidity to the language -that ensures that compiling to a lower-level language only requires a -limited set of transformations. Practically speaking, consider the -GHIL type, @code{}, which has fields named @code{env}, -@code{loc}, and @code{exp}. Instances of this type are records created -via @code{make-ghil-quote}, and whose fields are accessed as -@code{ghil-quote-env}, @code{ghil-quote-loc}, and -@code{ghil-quote-exp}. There is also a predicate, @code{ghil-quote?}. -@xref{Records}, for more information on records. +Tree-IL is ``structured'' in the sense that its representation is +based on records, not S-expressions. This gives a rigidity to the +language that ensures that compiling to a lower-level language only +requires a limited set of transformations. Practically speaking, +consider the Tree-IL type, @code{}, which has two fields, +@code{src} and @code{exp}. Instances of this type are records created +via @code{make-const}, and whose fields are accessed as +@code{const-src}, and @code{const-exp}. There is also a predicate, +@code{const?}. @xref{Records}, for more information on records. -Expressions of GHIL name their environments explicitly, and all -variables are referenced by identity in addition to by name. -@code{(language ghil)} defines a number of routines to deal explicitly -with variables and environments: +@c alpha renaming -@deftp {Scheme Variable} [table='()] -A toplevel environment. The @var{table} holds all toplevel variables -that have been resolved in this environment. -@end deftp -@deftp {Scheme Variable} parent [table='()] [variables='()] -A lexical environment. @var{parent} will be the enclosing lexical -environment, or a toplevel environment. @var{table} holds an alist -mapping symbols to variables bound in this environment, while -@var{variables} holds a cumulative list of all variables ever defined -in this environment. +All Tree-IL types have a @code{src} slot, which holds source location +information for the expression. This information, if present, will be +residualized into the compiled object code, allowing backtraces to +show source information. The format of @code{src} is the same as that +returned by Guile's @code{source-properties} function. @xref{Source +Properties}, for more information. -Lexical environments correspond to procedures. Bindings introduced -e.g. by Scheme's @code{let} add to the bindings in a lexical -environment. An example of a case in which a variable might be in -@var{variables} but not in @var{table} would be a variable that is in -the same procedure, but is out of scope. -@end deftp -@deftp {Scheme Variable} env name kind [index=#f] -A variable. @var{kind} is one of @code{argument}, @code{local}, -@code{external}, @code{toplevel}, @code{public}, or @code{private}; -see the procedures below for more information. @var{index} is used in -compilation. -@end deftp - -@deffn {Scheme Procedure} ghil-var-is-bound? env sym -Recursively look up a variable named @var{sym} in @var{env}, and -return it or @code{#f} if none is found. -@end deffn -@deffn {Scheme Procedure} ghil-var-for-ref! env sym -Recursively look up a variable named @var{sym} in @var{env}, and -return it. If the symbol was not bound, return a new toplevel -variable. -@end deffn -@deffn {Scheme Procedure} ghil-var-for-set! env sym -Like @code{ghil-var-for-ref!}, except that the returned variable will -be marked as @code{external}. @xref{Variables and the VM}. -@end deffn -@deffn {Scheme Procedure} ghil-var-define! toplevel-env sym -Return an existing or new toplevel variable named @var{sym}. -@var{toplevel-env} must be a toplevel environment. -@end deffn -@deffn {Scheme Procedure} ghil-var-at-module! env modname sym interface? -Return a variable that will be resolved at run-time with respect to a -specific module named @var{modname}. If @var{interface?} is true, the -variable will be of type @code{public}, otherwise @code{private}. -@end deffn -@deffn {Scheme Procedure} call-with-ghil-environment env syms func -Bind @var{syms} to fresh variables within a new lexical environment -whose parent is @var{env}, and call @var{func} as @code{(@var{func} -@var{new-env} @var{new-vars})}. -@end deffn -@deffn {Scheme Procedure} call-with-ghil-bindings env syms func -Like @code{call-with-ghil-environment}, except the existing -environment @var{env} is re-used. For that reason, @var{func} is -invoked as @code{(@var{func} @var{new-vars})} -@end deffn - -In the aforementioned @code{} type, the @var{env} slot -holds a pointer to the environment in which the expression occurs. The -@var{loc} slot holds source location information, so that errors -corresponding to this expression can be mapped back to the initial -expression in the higher-level language, e.g. Scheme. @xref{Compiled -Procedures}, for more information on source location objects. - -GHIL also has a declarative serialization format, which makes writing -and reading it a tractable problem for the human mind. Since all GHIL -language constructs contain @code{env} and @code{loc} pointers, they -are left out of the serialization. (Serializing @code{env} structures -would be difficult, as they are often circular.) What is left is the -type of expression, and the remaining slots defined in the expression -type. - -For example, an S-expression representation of the @code{} -expression would be: +Although Tree-IL objects are represented internally using records, +there is also an equivalent S-expression external representation for +each kind of Tree-IL. For example, an the S-expression representation +of @code{#} expression would be: @example -(quote 3) +(const 3) @end example -It's deceptively like Scheme. The general rule is, for a type defined -as @code{ env loc @var{slot1} @var{slot2}...}, the -S-expression representation will be @code{(@var{foo} @var{slot1} -@var{slot2}...)}. Users may program with this format directly at the -REPL: +Users may program with this format directly at the REPL: @example -scheme@@(guile-user)> ,language ghil -Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0 +scheme@@(guile-user)> ,language tree-il +Tree Intermediate Language interpreter 1.0 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -ghil@@(guile-user)> (call (ref +) (quote 32) (quote 10)) +tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10)) @result{} 42 @end example -For convenience, some slots are serialized as rest arguments; those -are noted below. The other caveat is that variables are serialized as -their names only, and not their identities. +The @code{src} fields are left out of the external representation. -@deftp {Scheme Variable} env loc -The unspecified value. +@deftp {Scheme Variable} src +@deftpx {External Representation} (void) +An empty expression. In practice, equivalent to Scheme's @code{(if #f +#f)}. @end deftp -@deftp {Scheme Variable} env loc exp -A quoted expression. +@deftp {Scheme Variable} src exp +@deftpx {External Representation} (const @var{exp}) +A constant. +@end deftp +@deftp {Scheme Variable} src name +@deftpx {External Representation} (primitive @var{name}) +A reference to a ``primitive''. A primitive is a procedure that, when +compiled, may be open-coded. For example, @code{cons} is usually +recognized as a primitive, so that it compiles down to a single +instruction. -Note that unlike in Scheme, there are no self-quoting expressions; all -constants must come from @code{quote} expressions. +Compilation of Tree-IL usually begins with a pass that resolves some +@code{} and @code{} expressions to +@code{} expressions. The actual compilation pass +has special cases for applications of certain primitives, like +@code{apply} or @code{cons}. @end deftp -@deftp {Scheme Variable} env loc exp -A quasiquoted expression. The expression is treated as a constant, -except for embedded @code{unquote} and @code{unquote-splicing} forms. +@deftp {Scheme Variable} src name gensym +@deftpx {External Representation} (lexical @var{name} @var{gensym}) +A reference to a lexically-bound variable. The @var{name} is the +original name of the variable in the source program. @var{gensym} is a +unique identifier for this variable. @end deftp -@deftp {Scheme Variable} env loc exp -Like Scheme's @code{unquote}; only valid within a quasiquote. +@deftp {Scheme Variable} src name gensym exp +@deftpx {External Representation} (set! (lexical @var{name} @var{gensym}) @var{exp}) +Sets a lexically-bound variable. @end deftp -@deftp {Scheme Variable} env loc exp -Like Scheme's @code{unquote-splicing}; only valid within a quasiquote. +@deftp {Scheme Variable} src mod name public? +@deftpx {External Representation} (@@ @var{mod} @var{name}) +@deftpx {External Representation} (@@@@ @var{mod} @var{name}) +A reference to a variable in a specific module. @var{mod} should be +the name of the module, e.g. @code{(guile-user)}. + +If @var{public?} is true, the variable named @var{name} will be looked +up in @var{mod}'s public interface, and serialized with @code{@@}; +otherwise it will be looked up among the module's private bindings, +and is serialized with @code{@@@@}. @end deftp -@deftp {Scheme Variable} env loc var -A variable reference. Note that for purposes of serialization, -@var{var} is serialized as its name, as a symbol. +@deftp {Scheme Variable} src mod name public? exp +@deftpx {External Representation} (set! (@@ @var{mod} @var{name}) @var{exp}) +@deftpx {External Representation} (set! (@@@@ @var{mod} @var{name}) @var{exp}) +Sets a variable in a specific module. @end deftp -@deftp {Scheme Variable} env loc var val -A variable mutation. @var{var} is serialized as a symbol. +@deftp {Scheme Variable} src name +@deftpx {External Representation} (toplevel @var{name}) +References a variable from the current procedure's module. @end deftp -@deftp {Scheme Variable} env loc var val -A toplevel variable definition. See @code{ghil-var-define!}. +@deftp {Scheme Variable} src name exp +@deftpx {External Representation} (set! (toplevel @var{name}) @var{exp}) +Sets a variable in the current procedure's module. @end deftp -@deftp {Scheme Variable} env loc test then else +@deftp {Scheme Variable} src name exp +@deftpx {External Representation} (define (toplevel @var{name}) @var{exp}) +Defines a new top-level variable in the current procedure's module. +@end deftp +@deftp {Scheme Variable} src test then else +@deftpx {External Representation} (if @var{test} @var{then} @var{else}) A conditional. Note that @var{else} is not optional. @end deftp -@deftp {Scheme Variable} env loc . exps -Like Scheme's @code{and}. -@end deftp -@deftp {Scheme Variable} env loc . exps -Like Scheme's @code{or}. -@end deftp -@deftp {Scheme Variable} env loc . body -Like Scheme's @code{begin}. -@end deftp -@deftp {Scheme Variable} env loc vars exprs . body -Like a deconstructed @code{let}: each element of @var{vars} will be -bound to the corresponding GHIL expression in @var{exprs}. - -Note that for purposes of the serialization format, @var{exprs} are -evaluated before the new bindings are added to the environment. For -@code{letrec} semantics, there also exists a @code{bindrec} parse -flavor. This is useful for writing GHIL at the REPL, but the -serializer does not currently have the cleverness needed to determine -whether a @code{} has @code{let} or @code{letrec} -semantics, and thus only serializes @code{} as @code{bind}. -@end deftp -@deftp {Scheme Variable} env loc vars rest producer . body -Like Scheme's @code{receive} -- binds the values returned by -applying @code{producer}, which should be a thunk, to the -@code{lambda}-like bindings described by @var{vars} and @var{rest}. -@end deftp -@deftp {Scheme Variable} env loc vars rest meta . body -A closure. @var{vars} is the argument list, serialized as a list of -symbols. @var{rest} is a boolean, which is @code{#t} iff the last -argument is a rest argument. @var{meta} is an association list of -properties. The actual @var{body} should be a list of GHIL -expressions. -@end deftp -@deftp {Scheme Variable} env loc proc . args +@deftp {Scheme Variable} src proc args +@deftpx {External Representation} (apply @var{proc} . @var{args}) A procedure call. @end deftp -@deftp {Scheme Variable} env loc producer consumer -Like Scheme's @code{call-with-values}. +@deftp {Scheme Variable} src exps +@deftpx {External Representation} (begin . @var{exps}) +Like Scheme's @code{begin}. @end deftp -@deftp {Scheme Variable} env loc op . args -An inlined VM instruction. @var{op} should be the instruction name as -a symbol, and @var{args} should be its arguments, as GHIL expressions. +@deftp {Scheme Variable} src names vars meta body +@deftpx {External Representation} (lambda @var{names} @var{vars} @var{meta} @var{body}) +A closure. @var{names} is original binding form, as given in the +source code, which may be an improper list. @var{vars} are gensyms +corresponding to the @var{names}. @var{meta} is an association list of +properties. The actual @var{body} is a single Tree-IL expression. @end deftp -@deftp {Scheme Variable} env loc . values -Like Scheme's @code{values}. +@deftp {Scheme Variable} src names vars vals exp +@deftpx {External Representation} (let @var{names} @var{vars} @var{vals} @var{exp}) +Lexical binding, like Scheme's @code{let}. @var{names} are the +original binding names, @var{vars} are gensyms corresponding to the +@var{names}, and @var{vals} are Tree-IL expressions for the values. +@var{exp} is a single Tree-IL expression. @end deftp -@deftp {Scheme Variable} env loc . values -@var{values} are as in the Scheme expression, @code{(apply values . -@var{vals})}. -@end deftp -@deftp {Scheme Variable} env loc -Produces, at run-time, a reification of the environment at compile -time. Used in the implementation of Scheme's -@code{compile-time-environment}. +@deftp {Scheme Variable} src names vars vals exp +@deftpx {External Representation} (letrec @var{names} @var{vars} @var{vals} @var{exp}) +A version of @code{} that creates recursive bindings, like +Scheme's @code{letrec}. @end deftp -GHIL implements a compiler to GLIL that recursively traverses GHIL -expressions, writing out GLIL expressions into a linear list. The -compiler also keeps some state as to whether the current expression is -in tail context, and whether its value will be used in future -computations. This state allows the compiler not to emit code for -constant expressions that will not be used (e.g. docstrings), and to -perform tail calls when in tail position. +@c FIXME -- need to revive this one +@c @deftp {Scheme Variable} src vars rest producer . body +@c Like Scheme's @code{receive} -- binds the values returned by +@c applying @code{producer}, which should be a thunk, to the +@c @code{lambda}-like bindings described by @var{vars} and @var{rest}. +@c @end deftp -Just as the Scheme to GHIL compiler introduced new hidden state---the -environment---the GHIL to GLIL compiler introduces more state, the -stack. While not represented explicitly, the stack is present in the -compilation of each GHIL expression: compiling a GHIL expression -should leave the run-time value stack in the same state. For example, -if the intermediate value stack has two elements before evaluating an -@code{if} expression, it should have two elements after that -expression. +Tree-IL implements a compiler to GLIL that recursively traverses +Tree-IL expressions, writing out GLIL expressions into a linear list. +The compiler also keeps some state as to whether the current +expression is in tail context, and whether its value will be used in +future computations. This state allows the compiler not to emit code +for constant expressions that will not be used (e.g. docstrings), and +to perform tail calls when in tail position. + +In the future, there will be a pass at the beginning of the +Tree-IL->GLIL compilation step to perform inlining, copy propagation, +dead code elimination, and constant folding. Interested readers are encouraged to read the implementation in -@code{(language ghil compile-glil)} for more details. +@code{(language tree-il compile-glil)} for more details. @node GLIL @subsection GLIL Guile Low Intermediate Language (GLIL) is a structured intermediate -language whose expressions closely mirror the functionality of Guile's -VM instruction set. +language whose expressions more closely approximate Guile's VM +instruction set. Its expression types are defined in @code{(language glil)}, and as with GHIL, some of its fields parse as rest arguments. @@ -499,8 +420,8 @@ A unit of code that at run-time will correspond to a compiled procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts} collectively define the program's arity; see @ref{Compiled Procedures}, for more information. @var{meta} should be an alist of -properties, as in @code{}. @var{body} is a list of GLIL -expressions. +properties, as in Tree IL's @code{}. @var{body} is a list of +GLIL expressions. @end deftp @deftp {Scheme Variable} . vars An advisory expression that notes a liveness extent for a set of @@ -534,24 +455,23 @@ offset within a VM program. @end deftp @deftp {Scheme Variable} loc Records source information for the preceding expression. @var{loc} -should be a vector, @code{#(@var{line} @var{column} @var{filename})}. +should be an association list of containing @code{line} @code{column}, +and @code{filename} keys, e.g. as returned by +@code{source-properties}. @end deftp @deftp {Scheme Variable} Pushes the unspecified value on the stack. @end deftp @deftp {Scheme Variable} obj Pushes a constant value onto the stack. @var{obj} must be a number, -string, symbol, keyword, boolean, character, or a pair or vector or -list thereof, or the empty list. -@end deftp -@deftp {Scheme Variable} op index -Accesses an argument on the stack. If @var{op} is @code{ref}, the -argument is pushed onto the stack; if it is @code{set}, the argument -is set from the top value on the stack, which is popped off. +string, symbol, keyword, boolean, character, the empty list, or a pair +or vector of constants. @end deftp @deftp {Scheme Variable} op index -Like @code{}, but for local variables. @xref{Stack -Layout}, for more information. +Accesses a lexically bound variable from the stack. If @var{op} is +@code{ref}, the value is pushed onto the stack; if it is @code{set}, +the variable is set from the top value on the stack, which is popped +off. @xref{Stack Layout}, for more information. @end deftp @deftp {Scheme Variable} op depth index Accesses a heap-allocated variable, addressed by @var{depth}, the nth @@ -563,8 +483,8 @@ Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set}, or @code{define}. @end deftp @deftp {Scheme Variable} op mod name public? -Accesses a variable within a specific module. See -@code{ghil-var-at-module!}, for more information. +Accesses a variable within a specific module. See Tree-IL's +@code{}, for more information. @end deftp @deftp {Scheme Variable} label Creates a new label. @var{label} can be any Scheme value, and should @@ -607,23 +527,143 @@ Just as in all of Guile's compilers, an environment is passed to the GLIL-to-object code compiler, and one is returned as well, along with the object code. -@node Object Code -@subsection Object Code +@node Assembly +@subsection Assembly -Object code is the serialization of the raw instruction stream of a -program, ready for interpretation by the VM. Procedures related to -object code are defined in the @code{(system vm objcode)} module. +Assembly is an S-expression-based, human-readable representation of +the actual bytecodes that will be emitted for the VM. As such, it is a +useful intermediate language both for compilation and for +decompilation. + +Besides the fact that it is not a record-based language, assembly +differs from GLIL in four main ways: + +@itemize +@item Labels have been resolved to byte offsets in the program. +@item Constants inside procedures have either been expressed as inline +instructions, and possibly cached in object arrays. +@item Procedures with metadata (source location information, liveness +extents, procedure names, generic properties, etc) have had their +metadata serialized out to thunks. +@item All expressions correspond directly to VM instructions -- i.e., +there is no @code{} which can be a ref or a set. +@end itemize + +Assembly is isomorphic to the bytecode that it compiles to. You can +compile to bytecode, then decompile back to assembly, and you have the +same assembly code. + +The general form of assembly instructions is the following: + +@lisp +(@var{inst} @var{arg} ...) +@end lisp + +The @var{inst} names a VM instruction, and its @var{arg}s will be +embedded in the instruction stream. The easiest way to see assembly is +to play around with it at the REPL, as can be seen in this annotated +example: + +@example +scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly) +(load-program 0 0 0 0 + () ; Labels + 60 ; Length + #f ; Metadata + (make-false) ; object table for the returned lambda + (nop) + (nop) ; Alignment. Since assembly has already resolved its labels + (nop) ; to offsets, and programs must be 8-byte aligned since their + (nop) ; object code is mmap'd directly to structures, assembly + (nop) ; has to have the alignment embedded in it. + (nop) + (load-program 1 0 0 0 + () + 6 + ; This is the metadata thunk for the returned procedure. + (load-program 0 0 0 0 () 21 #f + (load-symbol "x") ; Name and liveness extent for @code{x}. + (make-false) + (make-int8:0) ; Some instruction+arg combinations + (make-int8:0) ; have abbreviations. + (make-int8 6) + (list 0 5) + (list 0 1) + (make-eol) + (list 0 2) + (return)) + ; And here, the actual code. + (local-ref 0) + (local-ref 0) + (add) + (return)) + ; Return our new procedure. + (return)) +@end example + +Of course you can switch the REPL to assembly and enter in assembly +S-expressions directly, like with other languages, though it is more +difficult, given that the length fields have to be correct. + +@node Bytecode and Objcode +@subsection Bytecode and Objcode + +Finally, the raw bytes. There are actually two different ``languages'' +here, corresponding to two different ways to represent the bytes. + +``Bytecode'' represents code as uniform byte vectors, useful for +structuring and destructuring code on the Scheme level. Bytecode is +the next step down from assembly: + +@example +scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly) +@result{} (load-program 0 0 0 0 () 6 #f + (make-int8 32) (make-int8 10) (add) (return)) +scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode) +@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 10 32 10 10 100 48) +@end example + +``Objcode'' is bytecode, but mapped directly to a C structure, +@code{struct scm_objcode}: + +@example +struct scm_objcode @{ + scm_t_uint8 nargs; + scm_t_uint8 nrest; + scm_t_uint8 nlocs; + scm_t_uint8 nexts; + scm_t_uint32 len; + scm_t_uint32 metalen; + scm_t_uint8 base[0]; +@}; +@end example + +As one might imagine, objcode imposes a minimum length on the +bytecode. Also, the multibyte fields are in native endianness, which +makes objcode (and bytecode) system-dependent. Indeed, in the short +example above, all but the last 5 bytes were the program's header. + +Objcode also has a couple of important efficiency hacks. First, +objcode may be mapped directly from disk, allowing compiled code to be +loaded quickly, often from the system's disk cache, and shared among +multiple processes. Secondly, objcode may be embedded in other +objcode, allowing procedures to have the text of other procedures +inlined into their bodies, without the need for separate allocation of +the code. Of course, the objcode object itself does need to be +allocated. + +Procedures related to objcode are defined in the @code{(system vm +objcode)} module. @deffn {Scheme Procedure} objcode? obj @deffnx {C Function} scm_objcode_p (obj) Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise. @end deffn -@deffn {Scheme Procedure} bytecode->objcode bytecode nlocs nexts -@deffnx {C Function} scm_bytecode_to_objcode (bytecode, nlocs, nexts) +@deffn {Scheme Procedure} bytecode->objcode bytecode +@deffnx {C Function} scm_bytecode_to_objcode (bytecode,) Makes a bytecode object from @var{bytecode}, which should be a -@code{u8vector}. @var{nlocs} and @var{nexts} denote the number of -stack and heap variables to reserve when this objcode is executed. +@code{u8vector}. @end deffn @deffn {Scheme Variable} load-objcode file @@ -631,21 +671,28 @@ stack and heap variables to reserve when this objcode is executed. Load object code from a file named @var{file}. The file will be mapped into memory via @code{mmap}, so this is a very fast operation. -On disk, object code has an eight-byte cookie prepended to it, so that -we will not execute arbitrary garbage. In addition, two more bytes are -reserved for @var{nlocs} and @var{nexts}. +On disk, object code has an eight-byte cookie prepended to it, to +prevent accidental loading of arbitrary garbage. +@end deffn + +@deffn {Scheme Variable} write-objcode objcode file +@deffnx {C Function} scm_write_objcode (objcode) +Write object code out to a file, prepending the eight-byte cookie. @end deffn @deffn {Scheme Variable} objcode->u8vector objcode @deffnx {C Function} scm_objcode_to_u8vector (objcode) -Copy object code out to a @code{u8vector} for analysis by Scheme. The -ten-byte header is included. +Copy object code out to a @code{u8vector} for analysis by Scheme. @end deffn -@deffn {Scheme Variable} objcode->program objcode [external='()] -@deffnx {C Function} scm_objcode_to_program (objcode, external) +The following procedure is actually in @code{(system vm program)}, but +we'll mention it here: + +@deffn {Scheme Variable} make-program objcode objtable [external='()] +@deffnx {C Function} scm_make_program (objcode, objtable, external) Load up object code into a Scheme program. The resulting program will -be a thunk that captures closure variables from @var{external}. +have @var{objtable} as its object table, which should be a vector or +@code{#f}, and will capture the closure variables from @var{external}. @end deffn Object code from a file may be disassembled at the REPL via the @@ -689,7 +736,7 @@ fruit, running programs of interest under a system-level profiler and determining which improvements would give the most bang for the buck. There are many well-known efficiency hacks in the literature: Dybvig's letrec optimization, individual boxing of heap-allocated values (and -then store the boxes on the stack directory), optimized case-lambda +then store the boxes on the stack directly), optimized case-lambda expressions, stack underflow and overflow handlers, etc. Highly recommended papers: Dybvig's HOCS, Ghuloum's compiler paper. diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 042645200..49b420c50 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -111,7 +111,7 @@ The registers that a VM has are as follows: In other architectures, the instruction pointer is sometimes called the ``program counter'' (pc). This set of registers is pretty typical for stack machines; their exact meanings in the context of Guile's VM -is described in the next section. +are described in the next section. A virtual machine executes by loading a compiled procedure, and executing the object code associated with that procedure. Of course, @@ -119,14 +119,17 @@ that procedure may call other procedures, tail-call others, ad infinitum---indeed, within a guile whose modules have all been compiled to object code, one might never leave the virtual machine. -@c wingo: I wish the following were true, but currently we just use -@c the one engine. This kind of thing is possible tho. +@c wingo: The following is true, but I don't know in what context to +@c describe it. A documentation FIXME. @c A VM may have one of three engines: reckless, regular, or debugging. @c Reckless engine is fastest but dangerous. Regular engine is normally @c fail-safe and reasonably fast. Debugging engine is safest and @c functional but very slow. +@c (Actually we have just a regular and a debugging engine; normally +@c we use the latter, it's almost as fast as the ``regular'' engine.) + @node Stack Layout @subsection Stack Layout @@ -174,7 +177,7 @@ The structure of the fixed part of an application frame is as follows: In the above drawing, the stack grows upward. The intermediate values stored in the application of this frame are stored above @code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the -@code{struct scm_program*} data associated with the program at +@code{struct scm_objcode} data associated with the program at @code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the compiled procedure, which will be discussed later. @@ -226,7 +229,7 @@ programs are implemented, @xref{VM Programs}. @node Variables and the VM @subsection Variables and the VM -Let's think about the following Scheme code as an example: +Consider the following Scheme code as an example: @example (define (foo a) @@ -236,22 +239,15 @@ Let's think about the following Scheme code as an example: Within the lambda expression, "foo" is a top-level variable, "a" is a lexically captured variable, and "b" is a local variable. -That is to say: @code{b} may safely be allocated on the stack, as -there is no enclosed procedure that references it, nor is it ever -mutated. +@code{b} may safely be allocated on the stack, as there is no enclosed +procedure that references it, nor is it ever mutated. @code{a}, on the other hand, is referenced by an enclosed procedure, that of the lambda. Thus it must be allocated on the heap, as it may (and will) outlive the dynamic extent of the invocation of @code{foo}. -@code{foo} is a toplevel variable, as mandated by Scheme's semantics: - -@example - (define proc (foo 'bar)) ; assuming prev. definition of @code{foo} - (define foo 42) ; redefinition - (proc 'baz) - @result{} (42 bar baz) -@end example +@code{foo} is a top-level variable, because it names the procedure +@code{foo}, which is here defined at the top-level. Note that variables that are mutated (via @code{set!}) must be allocated on the heap, even if they are local variables. This is @@ -276,6 +272,7 @@ You can pick apart these pieces with the accessors in @code{(system vm program)}. @xref{Compiled Procedures}, for a full API reference. @cindex object table +@cindex object array The object array of a compiled procedure, also known as the @dfn{object table}, holds all Scheme objects whose values are known not to change across invocations of the procedure: constant strings, @@ -293,31 +290,27 @@ instruction, which uses the object vector, and are almost as fast as local variable references. We can see how these concepts tie together by disassembling the -@code{foo} function to see what is going on: +@code{foo} function we defined earlier to see what is going on: @smallexample scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b))) scheme@@(guile-user)> ,x foo Disassembly of #: -Bytecode: - 0 (local-ref 0) ;; `a' (arg) 2 (external-set 0) ;; `a' (arg) - 4 (object-ref 0) ;; # - 6 (make-closure) at (unknown file):0:16 + 4 (object-ref 1) ;; #:0:16 (b)> + 6 (make-closure) 7 (return) ---------------------------------------- -Disassembly of #: +Disassembly of #:0:16 (b)>: -Bytecode: - - 0 (toplevel-ref 0) ;; `list' - 2 (toplevel-ref 1) ;; `foo' - 4 (external-ref 0) ;; (closure variable) - 6 (local-ref 0) ;; `b' (arg) - 8 (goto/args 3) at (unknown file):0:28 + 0 (toplevel-ref 1) ;; `foo' + 2 (external-ref 0) ;; (closure variable) + 4 (local-ref 0) ;; `b' (arg) + 6 (list 0 3) ;; 3 elements at (unknown file):0:28 + 9 (return) @end smallexample At @code{ip} 0 and 2, we do the copy from argument to heap for @@ -336,8 +329,9 @@ Control Instructions}, for more details. Then we see a reference to an external variable, corresponding to @code{a}. The disassembler doesn't have enough information to give a name to that variable, so it just marks it as being a ``closure -variable''. Finally we see the reference to @code{b}, then a tail call -(@code{goto/args}) with three arguments. +variable''. Finally we see the reference to @code{b}, then the +@code{list} opcode, an inline implementation of the @code{list} scheme +routine. @node Instruction Set @subsection Instruction Set @@ -365,7 +359,8 @@ their own test-and-branch instructions: @end example In addition, some Scheme primitives have their own inline -implementations, e.g. @code{cons}. +implementations, e.g. @code{cons}, and @code{list}, as we saw in the +previous section. So Guile's instruction set is a @emph{complete} instruction set, in that it provides the instructions that are suited to the problem, and @@ -421,12 +416,6 @@ efficient in the future via addressing by frame and index. Currently, external variables are all consed onto a list, which results in O(N) lookup time. -@deffn Instruction externals -Pushes the current list of external variables onto the stack. This -instruction is used in the implementation of -@code{compile-time-environment}. @xref{The Scheme Compiler}. -@end deffn - @deffn Instruction toplevel-ref index Push the value of the toplevel binding whose location is stored in at position @var{index} in the object table. @@ -440,11 +429,11 @@ created. Alternately, the lookup may be performed relative to a particular module, determined at compile-time (e.g. via @code{@@} or @code{@@@@}). In that case, the cell in the object table holds a list: -@code{(@var{modname} @var{sym} @var{interface?})}. The symbol -@var{sym} will be looked up in the module named @var{modname} (a list -of symbols). The lookup will be performed against the module's public -interface, unless @var{interface?} is @code{#f}, which it is for -example when compiling @code{@@@@}. +@code{(@var{modname} @var{sym} @var{public?})}. The symbol @var{sym} +will be looked up in the module named @var{modname} (a list of +symbols). The lookup will be performed against the module's public +interface, unless @var{public?} is @code{#f}, which it is for example +when compiling @code{@@@@}. In any case, if the symbol is unbound, an error is signalled. Otherwise the initial form is replaced with the looked-up variable, an @@ -550,8 +539,9 @@ may be encoded in 1, 2, or 4 bytes. @deffn Instruction load-integer length @deffnx Instruction load-unsigned-integer length -Load a 32-bit integer (respectively unsigned integer) from the -instruction stream. +Load a 32-bit integer or unsigned integer from the instruction stream. +The bytes of the integer are read in order of decreasing significance +(i.e., big-endian). @end deffn @deffn Instruction load-number length Load an arbitrary number from the instruction stream. The number is @@ -573,43 +563,23 @@ the current toplevel environment, creating the binding if necessary. Push the variable corresponding to the binding. @end deffn -@deffn Instruction load-program length +@deffn Instruction load-program Load bytecode from the instruction stream, and push a compiled -procedure. This instruction pops the following values from the stack: +procedure. -@itemize -@item Optionally, a thunk, which when called should return metadata -associated with this program---for example its name, the names of its -arguments, its documentation string, debugging information, etc. +This instruction pops one value from the stack: the program's object +table, as a vector, or @code{#f} in the case that the program has no +object table. A program that does not reference toplevel bindings and +does not use @code{object-ref} does not need an object table. -Normally, this thunk its itself a compiled procedure (with no -metadata). Metadata is represented this way so that the initial load -of a procedure is fast: the VM just mmap's the thunk and goes. The -symbols and pairs associated with the metadata are only created if the -user asks for them. - -For information on the format of the thunk's return value, -@xref{Compiled Procedures}. -@item Optionally, the program's object table, as a vector. - -A program that does not reference toplevel bindings and does not use -@code{object-ref} does not need an object table. -@item Finally, either one immediate integer or four immediate integers -representing the arity of the program. - -In the four-fixnum case, the values are respectively the number of -arguments taken by the function (@var{nargs}), the number of @dfn{rest -arguments} (@var{nrest}, 0 or 1), the number of local variables -(@var{nlocs}) and the number of external variables (@var{nexts}) -(@pxref{Environment Control Instructions}). - -The common single-fixnum case represents all of these values within a -16-bit bitmask. -@end itemize +This instruction is unlike the rest of the loading instructions, +because instead of parsing its data, it directly maps the instruction +stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode +and Objcode}, for more information. The resulting compiled procedure will not have any ``external'' -variables captured, so it will be loaded only once but may be used -many times to create closures. +variables captured, so it may be loaded only once but used many times +to create closures. @end deffn Finally, while this instruction is not strictly a ``loading'' @@ -620,7 +590,10 @@ here: Pop the program object from the stack, capture the current set of ``external'' variables, and assign those external variables to a copy of the program. Push the new program object, which shares state with -the original program. Also captures the current module. +the original program. + +At the time of this writing, the space overhead of closures is 4 words +per closure. @end deffn @node Procedural Instructions @@ -640,22 +613,24 @@ set to the returned value. @deffn Instruction call nargs Call the procedure located at @code{sp[-nargs]} with the @var{nargs} -arguments located from @code{sp[0]} to @code{sp[-nargs + 1]}. +arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}. + +For compiled procedures, this instruction sets up a new stack frame, +as described in @ref{Stack Layout}, and then dispatches to the first +instruction in the called procedure, relying on the called procedure +to return one value to the newly-created continuation. Because the new +frame pointer will point to sp[-nargs + 1], the arguments don't have +to be shuffled around -- they are already in place. For non-compiled procedures (continuations, primitives, and interpreted procedures), @code{call} will pop the procedure and arguments off the stack, and push the result of calling @code{scm_apply}. - -For compiled procedures, this instruction sets up a new stack frame, -as described in @ref{Stack Layout}, and then dispatches to the first -instruction in the called procedure, relying on the called procedure -to return one value to the newly-created continuation. @end deffn @deffn Instruction goto/args nargs Like @code{call}, but reusing the current continuation. This -instruction implements tail calling as required by RnRS. +instruction implements tail calls as required by RnRS. For compiled procedures, that means that @code{goto/args} reuses the current frame instead of building a new one. The @code{goto/*} @@ -726,14 +701,14 @@ values. This is an optimization for the common @code{(apply values @deffn Instruction truncate-values nbinds nrest Used in multiple-value continuations, this instruction takes the -values that are on the stack (including the number-of-value marker) +values that are on the stack (including the number-of-values marker) and truncates them for a binding construct. For example, a call to @code{(receive (x y . z) (foo) ...)} would, logically speaking, pop off the values returned from @code{(foo)} and push them as three values, corresponding to @code{x}, @code{y}, and @code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would -be 1 (to indicate that one of the bindings was a rest arguments). +be 1 (to indicate that one of the bindings was a rest argument). Signals an error if there is an insufficient number of values. @end deffn @@ -779,12 +754,14 @@ Push @var{value}, an 8-bit character, onto the stack. @deffn Instruction list n Pops off the top @var{n} values off of the stack, consing them up into a list, then pushes that list on the stack. What was the topmost value -will be the last element in the list. +will be the last element in the list. @var{n} is a two-byte value, +most significant byte first. @end deffn @deffn Instruction vector n Create and fill a vector with the top @var{n} values from the stack, -popping off those values and pushing on the resulting vector. +popping off those values and pushing on the resulting vector. @var{n} +is a two-byte value, like in @code{vector}. @end deffn @deffn Instruction mark @@ -850,9 +827,8 @@ Pushes ``the unspecified value'' onto the stack. @subsubsection Inlined Scheme Instructions The Scheme compiler can recognize the application of standard Scheme -procedures, or unbound variables that look like they are bound to -standard Scheme procedures. It tries to inline these small operations -to avoid the overhead of creating new stack frames. +procedures. It tries to inline these small operations to avoid the +overhead of creating new stack frames. Since most of these operations are historically implemented as C primitives, not inlining them would entail constantly calling out from @@ -876,12 +852,12 @@ stream. @deffnx Instruction eqv? x y @deffnx Instruction equal? x y @deffnx Instruction pair? x y -@deffnx Instruction list? x y +@deffnx Instruction list? x @deffnx Instruction set-car! pair x @deffnx Instruction set-cdr! pair x @deffnx Instruction slot-ref struct n @deffnx Instruction slot-set struct n x -@deffnx Instruction cons x +@deffnx Instruction cons x y @deffnx Instruction car x @deffnx Instruction cdr x Inlined implementations of their Scheme equivalents. diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index c35602f0c..19dda94db 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -169,24 +169,22 @@ (define-public (set-readline-read-hook! h) (set! read-hook h)) -(if (provided? 'regex) - (begin - (define-public apropos-completion-function - (let ((completions '())) - (lambda (text cont?) - (if (not cont?) - (set! completions - (map symbol->string - (apropos-internal - (string-append "^" (regexp-quote text)))))) - (if (null? completions) - #f - (let ((retval (car completions))) - (begin (set! completions (cdr completions)) - retval)))))) +(define-public apropos-completion-function + (let ((completions '())) + (lambda (text cont?) + (if (not cont?) + (set! completions + (map symbol->string + (apropos-internal + (string-append "^" (regexp-quote text)))))) + (if (null? completions) + #f + (let ((retval (car completions))) + (begin (set! completions (cdr completions)) + retval)))))) - (set! *readline-completion-function* apropos-completion-function) - )) +(if (provided? 'regex) + (set! *readline-completion-function* apropos-completion-function)) (define-public (with-readline-completion-function completer thunk) "With @var{completer} as readline completion function, call @var{thunk}." diff --git a/lang/Makefile.am b/lang/Makefile.am index 6dc2e2902..97c440d75 100644 --- a/lang/Makefile.am +++ b/lang/Makefile.am @@ -28,6 +28,7 @@ elisp_sources = \ elisp/example.el \ elisp/interface.scm \ elisp/transform.scm \ + elisp/expand.scm \ elisp/variables.scm \ \ elisp/primitives/buffers.scm \ diff --git a/lang/elisp/expand.scm b/lang/elisp/expand.scm new file mode 100644 index 000000000..0599d5984 --- /dev/null +++ b/lang/elisp/expand.scm @@ -0,0 +1,4 @@ +(define-module (lang elisp expand) + #:export (expand)) + +(define (expand x) x) diff --git a/lang/elisp/interface.scm b/lang/elisp/interface.scm index 1e0758569..fcd748f65 100644 --- a/lang/elisp/interface.scm +++ b/lang/elisp/interface.scm @@ -1,4 +1,5 @@ (define-module (lang elisp interface) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) #:use-module ((lang elisp internals load) #:select ((load . elisp:load))) @@ -66,31 +67,39 @@ one of the directories of @code{load-path}." (string->symbol (string-append "imports:" (number->string counter))))))) -(define-macro (use-elisp-file file-name . imports) - "Load Elisp code file @var{file-name} and import its definitions +(define use-elisp-file + (procedure->memoizing-macro + (lambda (exp env) + "Load Elisp code file @var{file-name} and import its definitions into the current Scheme module. If any @var{imports} are specified, they are interpreted as selection and renaming specifiers as per @code{use-modules}." - (let ((export-module-name (export-module-name))) - `(begin - (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) - (beautify-user-module! (resolve-module ',export-module-name)) - (load-elisp-file ,file-name) - (use-modules (,export-module-name ,@imports)) - (fluid-set! ,elisp-export-module #f)))) + (let ((file-name (cadr exp)) + (env (cddr exp))) + (let ((export-module-name (export-module-name))) + `(begin + (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) + (beautify-user-module! (resolve-module ',export-module-name)) + (load-elisp-file ,file-name) + (use-modules (,export-module-name ,@imports)) + (fluid-set! ,elisp-export-module #f))))))) -(define-macro (use-elisp-library library . imports) - "Load Elisp library @var{library} and import its definitions into +(define use-elisp-library + (procedure->memoizing-macro + (lambda (exp env) + "Load Elisp library @var{library} and import its definitions into the current Scheme module. If any @var{imports} are specified, they are interpreted as selection and renaming specifiers as per @code{use-modules}." - (let ((export-module-name (export-module-name))) - `(begin - (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) - (beautify-user-module! (resolve-module ',export-module-name)) - (load-elisp-library ,library) - (use-modules (,export-module-name ,@imports)) - (fluid-set! ,elisp-export-module #f)))) + (let ((library (cadr exp)) + (env (cddr exp))) + (let ((export-module-name (export-module-name))) + `(begin + (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) + (beautify-user-module! (resolve-module ',export-module-name)) + (load-elisp-library ,library) + (use-modules (,export-module-name ,@imports)) + (fluid-set! ,elisp-export-module #f))))))) (define (export-to-elisp . defs) "Export procedures and variables specified by @var{defs} to Elisp. diff --git a/lang/elisp/internals/lambda.scm b/lang/elisp/internals/lambda.scm index 9917c08bd..f7c7a4d01 100644 --- a/lang/elisp/internals/lambda.scm +++ b/lang/elisp/internals/lambda.scm @@ -1,4 +1,5 @@ (define-module (lang elisp internals lambda) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals fset) #:use-module (lang elisp transform) #:export (parse-formals diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm index f7a4aa003..7beb8a51c 100644 --- a/lang/elisp/primitives/fns.scm +++ b/lang/elisp/primitives/fns.scm @@ -26,7 +26,8 @@ (fset 'symbol-function fref/error-if-void) -(fset 'macroexpand macroexpand) +;; FIXME -- lost in the syncase conversion +;; (fset 'macroexpand macroexpand) (fset 'subrp (lambda (obj) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index 6babb3dd3..118b3bc0c 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -1,4 +1,5 @@ (define-module (lang elisp primitives syntax) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals lambda) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index ee288a722..09159c073 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -1,4 +1,5 @@ (define-module (lang elisp transform) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals trace) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals evaluation) @@ -26,23 +27,27 @@ (define (syntax-error x) (error "Syntax error in expression" x)) -(define-macro (scheme exp . module) - (let ((m (if (null? module) - the-root-module - (save-module-excursion - (lambda () - ;; In order for `resolve-module' to work as - ;; expected, the current module must contain the - ;; `app' variable. This is not true for #:pure - ;; modules, specifically (lang elisp base). So, - ;; switch to the root module (guile) before calling - ;; resolve-module. - (set-current-module the-root-module) - (resolve-module (car module))))))) - (let ((x `(,eval (,quote ,exp) ,m))) - ;;(write x) - ;;(newline) - x))) +(define scheme + (procedure->memoizing-macro + (lambda (exp env) + (let ((exp (cadr exp)) + (module (cddr exp))) + (let ((m (if (null? module) + the-root-module + (save-module-excursion + (lambda () + ;; In order for `resolve-module' to work as + ;; expected, the current module must contain the + ;; `app' variable. This is not true for #:pure + ;; modules, specifically (lang elisp base). So, + ;; switch to the root module (guile) before calling + ;; resolve-module. + (set-current-module the-root-module) + (resolve-module (car module))))))) + (let ((x `(,eval (,quote ,exp) ,m))) + ;;(write x) + ;;(newline) + x)))))) (define (transformer x) (cond ((pair? x) diff --git a/lib/Makefile.am b/lib/Makefile.am index 78693ea11..6f2f5c5fa 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,9 +9,9 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write putenv stdlib strcase strftime +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string -AUTOMAKE_OPTIONS = 1.5 gnits +AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects SUBDIRS = noinst_HEADERS = @@ -54,6 +54,42 @@ EXTRA_DIST += alloca.in.h ## end gnulib module alloca-opt +## begin gnulib module byteswap + +BUILT_SOURCES += $(BYTESWAP_H) + +# We need the following in order to create when the system +# doesn't have one. +byteswap.h: byteswap.in.h + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ + cat $(srcdir)/byteswap.in.h; \ + } > $@-t + mv -f $@-t $@ +MOSTLYCLEANFILES += byteswap.h byteswap.h-t + +EXTRA_DIST += byteswap.in.h + +## end gnulib module byteswap + +## begin gnulib module c-ctype + +libgnu_la_SOURCES += c-ctype.h c-ctype.c + +## end gnulib module c-ctype + +## begin gnulib module c-strcase + +libgnu_la_SOURCES += c-strcase.h c-strcasecmp.c c-strncasecmp.c + +## end gnulib module c-strcase + +## begin gnulib module c-strcaseeq + + +EXTRA_DIST += c-strcaseeq.h + +## end gnulib module c-strcaseeq + ## begin gnulib module configmake # Retrieve values of the variables through 'configure' followed by @@ -143,6 +179,82 @@ libgnu_la_SOURCES += full-write.h full-write.c ## end gnulib module full-write +## begin gnulib module gperf + +GPERF = gperf + +## end gnulib module gperf + +## begin gnulib module havelib + + +EXTRA_DIST += $(top_srcdir)/build-aux/config.rpath + +## end gnulib module havelib + +## begin gnulib module iconv_open + +BUILT_SOURCES += $(ICONV_H) + +# We need the following in order to create when the system +# doesn't have one that works with the given compiler. +iconv.h: iconv.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_ICONV_H''@|$(NEXT_ICONV_H)|g' \ + -e 's|@''ICONV_CONST''@|$(ICONV_CONST)|g' \ + -e 's|@''REPLACE_ICONV''@|$(REPLACE_ICONV)|g' \ + -e 's|@''REPLACE_ICONV_OPEN''@|$(REPLACE_ICONV_OPEN)|g' \ + -e 's|@''REPLACE_ICONV_UTF''@|$(REPLACE_ICONV_UTF)|g' \ + < $(srcdir)/iconv.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += iconv.h iconv.h-t + +iconv_open-aix.h: iconv_open-aix.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 + 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 + 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 + mv $(srcdir)/iconv_open-osf.h-t $(srcdir)/iconv_open-osf.h +BUILT_SOURCES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h +MOSTLYCLEANFILES += iconv_open-aix.h-t iconv_open-hpux.h-t iconv_open-irix.h-t iconv_open-osf.h-t +MAINTAINERCLEANFILES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h +EXTRA_DIST += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h + +EXTRA_DIST += iconv.in.h iconv_open-aix.gperf iconv_open-hpux.gperf iconv_open-irix.gperf iconv_open-osf.gperf iconv_open.c + +EXTRA_libgnu_la_SOURCES += iconv_open.c + +## end gnulib module iconv_open + +## begin gnulib module iconv_open-utf + + +EXTRA_DIST += iconv.c iconv_close.c + +EXTRA_libgnu_la_SOURCES += iconv.c iconv_close.c + +## end gnulib module iconv_open-utf + +## begin gnulib module lib-symbol-visibility + +# The value of $(CFLAG_VISIBILITY) needs to be added to the CFLAGS for the +# compilation of all sources that make up the library. This line here does it +# only for the gnulib part of it. The developer is responsible for adding +# $(CFLAG_VISIBILITY) to the Makefile.ams of the other portions of the library. +AM_CFLAGS += $(CFLAG_VISIBILITY) + +## end gnulib module lib-symbol-visibility + ## begin gnulib module link-warning LINK_WARNING_H=$(top_srcdir)/build-aux/link-warning.h @@ -432,6 +544,95 @@ EXTRA_libgnu_la_SOURCES += strftime.c ## end gnulib module strftime +## begin gnulib module striconveh + +libgnu_la_SOURCES += striconveh.h striconveh.c +if GL_COND_LIBTOOL +libgnu_la_LDFLAGS += $(LTLIBICONV) +endif + +EXTRA_DIST += iconveh.h + +## end gnulib module striconveh + +## begin gnulib module string + +BUILT_SOURCES += string.h + +# We need the following in order to create when the system +# doesn't have one that works with the given compiler. +string.h: string.in.h + rm -f $@-t $@ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''NEXT_STRING_H''@|$(NEXT_STRING_H)|g' \ + -e 's|@''GNULIB_MBSLEN''@|$(GNULIB_MBSLEN)|g' \ + -e 's|@''GNULIB_MBSNLEN''@|$(GNULIB_MBSNLEN)|g' \ + -e 's|@''GNULIB_MBSCHR''@|$(GNULIB_MBSCHR)|g' \ + -e 's|@''GNULIB_MBSRCHR''@|$(GNULIB_MBSRCHR)|g' \ + -e 's|@''GNULIB_MBSSTR''@|$(GNULIB_MBSSTR)|g' \ + -e 's|@''GNULIB_MBSCASECMP''@|$(GNULIB_MBSCASECMP)|g' \ + -e 's|@''GNULIB_MBSNCASECMP''@|$(GNULIB_MBSNCASECMP)|g' \ + -e 's|@''GNULIB_MBSPCASECMP''@|$(GNULIB_MBSPCASECMP)|g' \ + -e 's|@''GNULIB_MBSCASESTR''@|$(GNULIB_MBSCASESTR)|g' \ + -e 's|@''GNULIB_MBSCSPN''@|$(GNULIB_MBSCSPN)|g' \ + -e 's|@''GNULIB_MBSPBRK''@|$(GNULIB_MBSPBRK)|g' \ + -e 's|@''GNULIB_MBSSPN''@|$(GNULIB_MBSSPN)|g' \ + -e 's|@''GNULIB_MBSSEP''@|$(GNULIB_MBSSEP)|g' \ + -e 's|@''GNULIB_MBSTOK_R''@|$(GNULIB_MBSTOK_R)|g' \ + -e 's|@''GNULIB_MEMMEM''@|$(GNULIB_MEMMEM)|g' \ + -e 's|@''GNULIB_MEMPCPY''@|$(GNULIB_MEMPCPY)|g' \ + -e 's|@''GNULIB_MEMRCHR''@|$(GNULIB_MEMRCHR)|g' \ + -e 's|@''GNULIB_RAWMEMCHR''@|$(GNULIB_RAWMEMCHR)|g' \ + -e 's|@''GNULIB_STPCPY''@|$(GNULIB_STPCPY)|g' \ + -e 's|@''GNULIB_STPNCPY''@|$(GNULIB_STPNCPY)|g' \ + -e 's|@''GNULIB_STRCHRNUL''@|$(GNULIB_STRCHRNUL)|g' \ + -e 's|@''GNULIB_STRDUP''@|$(GNULIB_STRDUP)|g' \ + -e 's|@''GNULIB_STRNDUP''@|$(GNULIB_STRNDUP)|g' \ + -e 's|@''GNULIB_STRNLEN''@|$(GNULIB_STRNLEN)|g' \ + -e 's|@''GNULIB_STRPBRK''@|$(GNULIB_STRPBRK)|g' \ + -e 's|@''GNULIB_STRSEP''@|$(GNULIB_STRSEP)|g' \ + -e 's|@''GNULIB_STRSTR''@|$(GNULIB_STRSTR)|g' \ + -e 's|@''GNULIB_STRCASESTR''@|$(GNULIB_STRCASESTR)|g' \ + -e 's|@''GNULIB_STRTOK_R''@|$(GNULIB_STRTOK_R)|g' \ + -e 's|@''GNULIB_STRERROR''@|$(GNULIB_STRERROR)|g' \ + -e 's|@''GNULIB_STRSIGNAL''@|$(GNULIB_STRSIGNAL)|g' \ + -e 's|@''GNULIB_STRVERSCMP''@|$(GNULIB_STRVERSCMP)|g' \ + -e 's|@''HAVE_DECL_MEMMEM''@|$(HAVE_DECL_MEMMEM)|g' \ + -e 's|@''HAVE_MEMPCPY''@|$(HAVE_MEMPCPY)|g' \ + -e 's|@''HAVE_DECL_MEMRCHR''@|$(HAVE_DECL_MEMRCHR)|g' \ + -e 's|@''HAVE_RAWMEMCHR''@|$(HAVE_RAWMEMCHR)|g' \ + -e 's|@''HAVE_STPCPY''@|$(HAVE_STPCPY)|g' \ + -e 's|@''HAVE_STPNCPY''@|$(HAVE_STPNCPY)|g' \ + -e 's|@''HAVE_STRCHRNUL''@|$(HAVE_STRCHRNUL)|g' \ + -e 's|@''HAVE_DECL_STRDUP''@|$(HAVE_DECL_STRDUP)|g' \ + -e 's|@''HAVE_STRNDUP''@|$(HAVE_STRNDUP)|g' \ + -e 's|@''HAVE_DECL_STRNDUP''@|$(HAVE_DECL_STRNDUP)|g' \ + -e 's|@''HAVE_DECL_STRNLEN''@|$(HAVE_DECL_STRNLEN)|g' \ + -e 's|@''HAVE_STRPBRK''@|$(HAVE_STRPBRK)|g' \ + -e 's|@''HAVE_STRSEP''@|$(HAVE_STRSEP)|g' \ + -e 's|@''HAVE_STRCASESTR''@|$(HAVE_STRCASESTR)|g' \ + -e 's|@''HAVE_DECL_STRTOK_R''@|$(HAVE_DECL_STRTOK_R)|g' \ + -e 's|@''HAVE_DECL_STRERROR''@|$(HAVE_DECL_STRERROR)|g' \ + -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \ + -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \ + -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \ + -e 's|@''REPLACE_STRCASESTR''@|$(REPLACE_STRCASESTR)|g' \ + -e 's|@''REPLACE_STRDUP''@|$(REPLACE_STRDUP)|g' \ + -e 's|@''REPLACE_STRSTR''@|$(REPLACE_STRSTR)|g' \ + -e 's|@''REPLACE_STRERROR''@|$(REPLACE_STRERROR)|g' \ + -e 's|@''REPLACE_STRSIGNAL''@|$(REPLACE_STRSIGNAL)|g' \ + -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \ + < $(srcdir)/string.in.h; \ + } > $@-t + mv $@-t $@ +MOSTLYCLEANFILES += string.h string.h-t + +EXTRA_DIST += string.in.h + +## end gnulib module string + ## begin gnulib module strings BUILT_SOURCES += strings.h @@ -588,6 +789,50 @@ EXTRA_DIST += unistd.in.h ## end gnulib module unistd +## begin gnulib module unistr/base + + +EXTRA_DIST += unistr.h + +## end gnulib module unistr/base + +## begin gnulib module unistr/u8-mbtouc + +libgnu_la_SOURCES += unistr/u8-mbtouc.c unistr/u8-mbtouc-aux.c + +## end gnulib module unistr/u8-mbtouc + +## begin gnulib module unistr/u8-mbtouc-unsafe + +libgnu_la_SOURCES += unistr/u8-mbtouc-unsafe.c unistr/u8-mbtouc-unsafe-aux.c + +## end gnulib module unistr/u8-mbtouc-unsafe + +## begin gnulib module unistr/u8-mbtoucr + +libgnu_la_SOURCES += unistr/u8-mbtoucr.c + +## end gnulib module unistr/u8-mbtoucr + +## begin gnulib module unistr/u8-prev + +libgnu_la_SOURCES += unistr/u8-prev.c + +## end gnulib module unistr/u8-prev + +## begin gnulib module unistr/u8-uctomb + +libgnu_la_SOURCES += unistr/u8-uctomb.c unistr/u8-uctomb-aux.c + +## end gnulib module unistr/u8-uctomb + +## begin gnulib module unitypes + + +EXTRA_DIST += unitypes.h + +## end gnulib module unitypes + ## begin gnulib module verify libgnu_la_SOURCES += verify.h diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h new file mode 100644 index 000000000..f03463db6 --- /dev/null +++ b/lib/byteswap.in.h @@ -0,0 +1,44 @@ +/* byteswap.h - Byte swapping + Copyright (C) 2005, 2007 Free Software Foundation, Inc. + Written by Oskar Liljeblad , 2005. + + This program is free software: you can redistribute 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 _GL_BYTESWAP_H +#define _GL_BYTESWAP_H + +/* Given an unsigned 16-bit argument X, return the value corresponding to + X with reversed byte order. */ +#define bswap_16(x) ((((x) & 0x00FF) << 8) | \ + (((x) & 0xFF00) >> 8)) + +/* Given an unsigned 32-bit argument X, return the value corresponding to + X with reversed byte order. */ +#define bswap_32(x) ((((x) & 0x000000FF) << 24) | \ + (((x) & 0x0000FF00) << 8) | \ + (((x) & 0x00FF0000) >> 8) | \ + (((x) & 0xFF000000) >> 24)) + +/* Given an unsigned 64-bit argument X, return the value corresponding to + X with reversed byte order. */ +#define bswap_64(x) ((((x) & 0x00000000000000FFULL) << 56) | \ + (((x) & 0x000000000000FF00ULL) << 40) | \ + (((x) & 0x0000000000FF0000ULL) << 24) | \ + (((x) & 0x00000000FF000000ULL) << 8) | \ + (((x) & 0x000000FF00000000ULL) >> 8) | \ + (((x) & 0x0000FF0000000000ULL) >> 24) | \ + (((x) & 0x00FF000000000000ULL) >> 40) | \ + (((x) & 0xFF00000000000000ULL) >> 56)) + +#endif /* _GL_BYTESWAP_H */ diff --git a/lib/c-ctype.c b/lib/c-ctype.c new file mode 100644 index 000000000..e36a51340 --- /dev/null +++ b/lib/c-ctype.c @@ -0,0 +1,396 @@ +/* Character handling in C locale. + + Copyright 2000-2003, 2006 Free Software Foundation, Inc. + +This program is free software; you can redistribute 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, write to the Free Software Foundation, +Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#define NO_C_CTYPE_MACROS +#include "c-ctype.h" + +/* The function isascii is not locale dependent. Its use in EBCDIC is + questionable. */ +bool +c_isascii (int c) +{ + return (c >= 0x00 && c <= 0x7f); +} + +bool +c_isalnum (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z')); +#else + return ((c >= '0' && c <= '9') + || (c >= 'A' && c <= 'Z') + || (c >= 'a' && c <= 'z')); +#endif +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isalpha (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'); +#else + return ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')); +#endif +#else + switch (c) + { + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isblank (int c) +{ + return (c == ' ' || c == '\t'); +} + +bool +c_iscntrl (int c) +{ +#if C_CTYPE_ASCII + return ((c & ~0x1f) == 0 || c == 0x7f); +#else + switch (c) + { + case ' ': case '!': case '"': case '#': case '$': case '%': + case '&': case '\'': case '(': case ')': case '*': case '+': + case ',': case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 0; + default: + return 1; + } +#endif +} + +bool +c_isdigit (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS + return (c >= '0' && c <= '9'); +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + return 1; + default: + return 0; + } +#endif +} + +bool +c_islower (int c) +{ +#if C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'a' && c <= 'z'); +#else + switch (c) + { + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isgraph (int c) +{ +#if C_CTYPE_ASCII + return (c >= '!' && c <= '~'); +#else + switch (c) + { + case '!': case '"': case '#': case '$': case '%': case '&': + case '\'': case '(': case ')': case '*': case '+': case ',': + case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isprint (int c) +{ +#if C_CTYPE_ASCII + return (c >= ' ' && c <= '~'); +#else + switch (c) + { + case ' ': case '!': case '"': case '#': case '$': case '%': + case '&': case '\'': case '(': case ')': case '*': case '+': + case ',': case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_ispunct (int c) +{ +#if C_CTYPE_ASCII + return ((c >= '!' && c <= '~') + && !((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'))); +#else + switch (c) + { + case '!': case '"': case '#': case '$': case '%': case '&': + case '\'': case '(': case ')': case '*': case '+': case ',': + case '-': case '.': case '/': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case '[': case '\\': case ']': case '^': case '_': case '`': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isspace (int c) +{ + return (c == ' ' || c == '\t' + || c == '\n' || c == '\v' || c == '\f' || c == '\r'); +} + +bool +c_isupper (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE + return (c >= 'A' && c <= 'Z'); +#else + switch (c) + { + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isxdigit (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'F')); +#else + return ((c >= '0' && c <= '9') + || (c >= 'A' && c <= 'F') + || (c >= 'a' && c <= 'f')); +#endif +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + return 1; + default: + return 0; + } +#endif +} + +int +c_tolower (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c); +#else + switch (c) + { + case 'A': return 'a'; + case 'B': return 'b'; + case 'C': return 'c'; + case 'D': return 'd'; + case 'E': return 'e'; + case 'F': return 'f'; + case 'G': return 'g'; + case 'H': return 'h'; + case 'I': return 'i'; + case 'J': return 'j'; + case 'K': return 'k'; + case 'L': return 'l'; + case 'M': return 'm'; + case 'N': return 'n'; + case 'O': return 'o'; + case 'P': return 'p'; + case 'Q': return 'q'; + case 'R': return 'r'; + case 'S': return 's'; + case 'T': return 't'; + case 'U': return 'u'; + case 'V': return 'v'; + case 'W': return 'w'; + case 'X': return 'x'; + case 'Y': return 'y'; + case 'Z': return 'z'; + default: return c; + } +#endif +} + +int +c_toupper (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c); +#else + switch (c) + { + case 'a': return 'A'; + case 'b': return 'B'; + case 'c': return 'C'; + case 'd': return 'D'; + case 'e': return 'E'; + case 'f': return 'F'; + case 'g': return 'G'; + case 'h': return 'H'; + case 'i': return 'I'; + case 'j': return 'J'; + case 'k': return 'K'; + case 'l': return 'L'; + case 'm': return 'M'; + case 'n': return 'N'; + case 'o': return 'O'; + case 'p': return 'P'; + case 'q': return 'Q'; + case 'r': return 'R'; + case 's': return 'S'; + case 't': return 'T'; + case 'u': return 'U'; + case 'v': return 'V'; + case 'w': return 'W'; + case 'x': return 'X'; + case 'y': return 'Y'; + case 'z': return 'Z'; + default: return c; + } +#endif +} diff --git a/lib/c-ctype.h b/lib/c-ctype.h new file mode 100644 index 000000000..d7b067e83 --- /dev/null +++ b/lib/c-ctype.h @@ -0,0 +1,295 @@ +/* Character handling in C locale. + + These functions work like the corresponding functions in , + except that they have the C (POSIX) locale hardwired, whereas the + functions' behaviour depends on the current locale set via + setlocale. + + Copyright (C) 2000-2003, 2006, 2008 Free Software Foundation, Inc. + +This program is free software; you can redistribute 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, write to the Free Software Foundation, +Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef C_CTYPE_H +#define C_CTYPE_H + +#include + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* The functions defined in this file assume the "C" locale and a character + set without diacritics (ASCII-US or EBCDIC-US or something like that). + Even if the "C" locale on a particular system is an extension of the ASCII + character set (like on BeOS, where it is UTF-8, or on AmigaOS, where it + is ISO-8859-1), the functions in this file recognize only the ASCII + 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) \ + && ('-' == 45) && ('.' == 46) && ('/' == 47) && ('0' == 48) \ + && ('1' == 49) && ('2' == 50) && ('3' == 51) && ('4' == 52) \ + && ('5' == 53) && ('6' == 54) && ('7' == 55) && ('8' == 56) \ + && ('9' == 57) && (':' == 58) && (';' == 59) && ('<' == 60) \ + && ('=' == 61) && ('>' == 62) && ('?' == 63) && ('A' == 65) \ + && ('B' == 66) && ('C' == 67) && ('D' == 68) && ('E' == 69) \ + && ('F' == 70) && ('G' == 71) && ('H' == 72) && ('I' == 73) \ + && ('J' == 74) && ('K' == 75) && ('L' == 76) && ('M' == 77) \ + && ('N' == 78) && ('O' == 79) && ('P' == 80) && ('Q' == 81) \ + && ('R' == 82) && ('S' == 83) && ('T' == 84) && ('U' == 85) \ + && ('V' == 86) && ('W' == 87) && ('X' == 88) && ('Y' == 89) \ + && ('Z' == 90) && ('[' == 91) && ('\\' == 92) && (']' == 93) \ + && ('^' == 94) && ('_' == 95) && ('a' == 97) && ('b' == 98) \ + && ('c' == 99) && ('d' == 100) && ('e' == 101) && ('f' == 102) \ + && ('g' == 103) && ('h' == 104) && ('i' == 105) && ('j' == 106) \ + && ('k' == 107) && ('l' == 108) && ('m' == 109) && ('n' == 110) \ + && ('o' == 111) && ('p' == 112) && ('q' == 113) && ('r' == 114) \ + && ('s' == 115) && ('t' == 116) && ('u' == 117) && ('v' == 118) \ + && ('w' == 119) && ('x' == 120) && ('y' == 121) && ('z' == 122) \ + && ('{' == 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 +#endif + + +/* Function declarations. */ + +/* Unlike the functions in , which require an argument in the range + of the 'unsigned char' type, the functions here operate on values that are + in the 'unsigned char' range or in the 'char' range. In other words, + when you have a 'char' value, you need to cast it before using it as + argument to a function: + + const char *s = ...; + if (isalpha ((unsigned char) *s)) ... + + but you don't need to cast it for the functions defined in this file: + + const char *s = ...; + if (c_isalpha (*s)) ... + */ + +extern bool c_isascii (int c); /* not locale dependent */ + +extern bool c_isalnum (int c); +extern bool c_isalpha (int c); +extern bool c_isblank (int c); +extern bool c_iscntrl (int c); +extern bool c_isdigit (int c); +extern bool c_islower (int c); +extern bool c_isgraph (int c); +extern bool c_isprint (int c); +extern bool c_ispunct (int c); +extern bool c_isspace (int c); +extern bool c_isupper (int c); +extern bool c_isxdigit (int c); + +extern int c_tolower (int c); +extern int c_toupper (int c); + + +#if defined __GNUC__ && defined __OPTIMIZE__ && !defined __OPTIMIZE_SIZE__ && !defined NO_C_CTYPE_MACROS + +/* ASCII optimizations. */ + +#undef c_isascii +#define c_isascii(c) \ + ({ int __c = (c); \ + (__c >= 0x00 && __c <= 0x7f); \ + }) + +#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 + +#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 + +#undef c_isblank +#define c_isblank(c) \ + ({ int __c = (c); \ + (__c == ' ' || __c == '\t'); \ + }) + +#if C_CTYPE_ASCII +#undef c_iscntrl +#define c_iscntrl(c) \ + ({ int __c = (c); \ + ((__c & ~0x1f) == 0 || __c == 0x7f); \ + }) +#endif + +#if C_CTYPE_CONSECUTIVE_DIGITS +#undef c_isdigit +#define c_isdigit(c) \ + ({ int __c = (c); \ + (__c >= '0' && __c <= '9'); \ + }) +#endif + +#if C_CTYPE_CONSECUTIVE_LOWERCASE +#undef c_islower +#define c_islower(c) \ + ({ int __c = (c); \ + (__c >= 'a' && __c <= 'z'); \ + }) +#endif + +#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 */ + + +#ifdef __cplusplus +} +#endif + +#endif /* C_CTYPE_H */ diff --git a/lib/c-strcase.h b/lib/c-strcase.h new file mode 100644 index 000000000..714a3c623 --- /dev/null +++ b/lib/c-strcase.h @@ -0,0 +1,55 @@ +/* Case-insensitive string comparison functions in C locale. + Copyright (C) 1995-1996, 2001, 2003, 2005 Free Software Foundation, Inc. + + This program is free software; you can redistribute 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, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef C_STRCASE_H +#define C_STRCASE_H + +#include + + +/* The functions defined in this file assume the "C" locale and a character + set without diacritics (ASCII-US or EBCDIC-US or something like that). + Even if the "C" locale on a particular system is an extension of the ASCII + character set (like on BeOS, where it is UTF-8, or on AmigaOS, where it + is ISO-8859-1), the functions in this file recognize only the ASCII + characters. More precisely, one of the string arguments must be an ASCII + string; the other one can also contain non-ASCII characters (but then + the comparison result will be nonzero). */ + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Compare strings S1 and S2, ignoring case, returning less than, equal to or + greater than zero if S1 is lexicographically less than, equal to or greater + than S2. */ +extern int c_strcasecmp (const char *s1, const char *s2); + +/* Compare no more than N characters of strings S1 and S2, ignoring case, + returning less than, equal to or greater than zero if S1 is + lexicographically less than, equal to or greater than S2. */ +extern int c_strncasecmp (const char *s1, const char *s2, size_t n); + + +#ifdef __cplusplus +} +#endif + + +#endif /* C_STRCASE_H */ diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c new file mode 100644 index 000000000..a52389883 --- /dev/null +++ b/lib/c-strcasecmp.c @@ -0,0 +1,57 @@ +/* c-strcasecmp.c -- case insensitive string comparator in C locale + Copyright (C) 1998-1999, 2005-2006 Free Software Foundation, Inc. + + This program is free software; you can redistribute 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, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include "c-strcase.h" + +#include + +#include "c-ctype.h" + +int +c_strcasecmp (const char *s1, const char *s2) +{ + register const unsigned char *p1 = (const unsigned char *) s1; + register const unsigned char *p2 = (const unsigned char *) s2; + unsigned char c1, c2; + + if (p1 == p2) + return 0; + + do + { + c1 = c_tolower (*p1); + c2 = c_tolower (*p2); + + if (c1 == '\0') + break; + + ++p1; + ++p2; + } + while (c1 == c2); + + if (UCHAR_MAX <= INT_MAX) + return c1 - c2; + else + /* On machines where 'char' and 'int' are types of the same size, the + difference of two 'unsigned char' values - including the sign bit - + doesn't fit in an 'int'. */ + return (c1 > c2 ? 1 : c1 < c2 ? -1 : 0); +} diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h new file mode 100644 index 000000000..cd29b66c7 --- /dev/null +++ b/lib/c-strcaseeq.h @@ -0,0 +1,184 @@ +/* Optimized case-insensitive string comparison in C locale. + Copyright (C) 2001-2002, 2007 Free Software Foundation, Inc. + + This program is free software: you can redistribute 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 Bruno Haible . */ + +#include "c-strcase.h" +#include "c-ctype.h" + +/* STRCASEEQ allows to optimize string comparison with a small literal string. + STRCASEEQ (s, "UTF-8", 'U','T','F','-','8',0,0,0,0) + is semantically equivalent to + c_strcasecmp (s, "UTF-8") == 0 + just faster. */ + +/* Help GCC to generate good code for string comparisons with + immediate strings. */ +#if defined (__GNUC__) && defined (__OPTIMIZE__) + +/* Case insensitive comparison of ASCII characters. */ +# 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)) +# endif + +static inline int +strcaseeq9 (const char *s1, const char *s2) +{ + return c_strcasecmp (s1 + 9, s2 + 9) == 0; +} + +static inline int +strcaseeq8 (const char *s1, const char *s2, char s28) +{ + if (CASEEQ (s1[8], s28)) + { + if (s28 == 0) + return 1; + else + return strcaseeq9 (s1, s2); + } + else + return 0; +} + +static inline int +strcaseeq7 (const char *s1, const char *s2, char s27, char s28) +{ + if (CASEEQ (s1[7], s27)) + { + if (s27 == 0) + return 1; + else + return strcaseeq8 (s1, s2, s28); + } + else + return 0; +} + +static inline int +strcaseeq6 (const char *s1, const char *s2, char s26, char s27, char s28) +{ + if (CASEEQ (s1[6], s26)) + { + if (s26 == 0) + return 1; + else + return strcaseeq7 (s1, s2, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq5 (const char *s1, const char *s2, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[5], s25)) + { + if (s25 == 0) + return 1; + else + return strcaseeq6 (s1, s2, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq4 (const char *s1, const char *s2, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[4], s24)) + { + if (s24 == 0) + return 1; + else + return strcaseeq5 (s1, s2, s25, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq3 (const char *s1, const char *s2, char s23, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[3], s23)) + { + if (s23 == 0) + return 1; + else + return strcaseeq4 (s1, s2, s24, s25, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq2 (const char *s1, const char *s2, char s22, char s23, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[2], s22)) + { + if (s22 == 0) + return 1; + else + return strcaseeq3 (s1, s2, s23, s24, s25, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq1 (const char *s1, const char *s2, char s21, char s22, char s23, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[1], s21)) + { + if (s21 == 0) + return 1; + else + return strcaseeq2 (s1, s2, s22, s23, s24, s25, s26, s27, s28); + } + else + return 0; +} + +static inline int +strcaseeq0 (const char *s1, const char *s2, char s20, char s21, char s22, char s23, char s24, char s25, char s26, char s27, char s28) +{ + if (CASEEQ (s1[0], s20)) + { + if (s20 == 0) + return 1; + else + return strcaseeq1 (s1, s2, s21, s22, s23, s24, s25, s26, s27, s28); + } + else + return 0; +} + +#define STRCASEEQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \ + strcaseeq0 (s1, s2, s20, s21, s22, s23, s24, s25, s26, s27, s28) + +#else + +#define STRCASEEQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \ + (c_strcasecmp (s1, s2) == 0) + +#endif diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c new file mode 100644 index 000000000..c1496ca41 --- /dev/null +++ b/lib/c-strncasecmp.c @@ -0,0 +1,57 @@ +/* c-strncasecmp.c -- case insensitive string comparator in C locale + Copyright (C) 1998-1999, 2005-2006 Free Software Foundation, Inc. + + This program is free software; you can redistribute 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, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include "c-strcase.h" + +#include + +#include "c-ctype.h" + +int +c_strncasecmp (const char *s1, const char *s2, size_t n) +{ + register const unsigned char *p1 = (const unsigned char *) s1; + register const unsigned char *p2 = (const unsigned char *) s2; + unsigned char c1, c2; + + if (p1 == p2 || n == 0) + return 0; + + do + { + c1 = c_tolower (*p1); + c2 = c_tolower (*p2); + + if (--n == 0 || c1 == '\0') + break; + + ++p1; + ++p2; + } + while (c1 == c2); + + if (UCHAR_MAX <= INT_MAX) + return c1 - c2; + else + /* On machines where 'char' and 'int' are types of the same size, the + difference of two 'unsigned char' values - including the sign bit - + doesn't fit in an 'int'. */ + return (c1 > c2 ? 1 : c1 < c2 ? -1 : 0); +} diff --git a/lib/iconv.c b/lib/iconv.c new file mode 100644 index 000000000..56a84c456 --- /dev/null +++ b/lib/iconv.c @@ -0,0 +1,450 @@ +/* Character set conversion. + Copyright (C) 1999-2001, 2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute 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, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include + +#include + +#if REPLACE_ICONV_UTF +# include +# include +# include +# include "unistr.h" +# ifndef uintptr_t +# define uintptr_t unsigned long +# endif +#endif + +#if REPLACE_ICONV_UTF + +/* UTF-{16,32}{BE,LE} converters taken from GNU libiconv 1.11. */ + +/* Return code if invalid. (xxx_mbtowc) */ +# define RET_ILSEQ -1 +/* Return code if no bytes were read. (xxx_mbtowc) */ +# define RET_TOOFEW -2 + +/* Return code if invalid. (xxx_wctomb) */ +# define RET_ILUNI -1 +/* Return code if output buffer is too small. (xxx_wctomb, xxx_reset) */ +# define RET_TOOSMALL -2 + +/* + * UTF-16BE + */ + +/* Specification: RFC 2781 */ + +static int +utf16be_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n) +{ + if (n >= 2) + { + ucs4_t wc = (s[0] << 8) + s[1]; + if (wc >= 0xd800 && wc < 0xdc00) + { + if (n >= 4) + { + ucs4_t wc2 = (s[2] << 8) + s[3]; + if (!(wc2 >= 0xdc00 && wc2 < 0xe000)) + return RET_ILSEQ; + *pwc = 0x10000 + ((wc - 0xd800) << 10) + (wc2 - 0xdc00); + return 4; + } + } + else if (wc >= 0xdc00 && wc < 0xe000) + { + return RET_ILSEQ; + } + else + { + *pwc = wc; + return 2; + } + } + return RET_TOOFEW; +} + +static int +utf16be_wctomb (unsigned char *r, ucs4_t wc, size_t n) +{ + if (!(wc >= 0xd800 && wc < 0xe000)) + { + if (wc < 0x10000) + { + if (n >= 2) + { + r[0] = (unsigned char) (wc >> 8); + r[1] = (unsigned char) wc; + return 2; + } + else + return RET_TOOSMALL; + } + else if (wc < 0x110000) + { + if (n >= 4) + { + ucs4_t wc1 = 0xd800 + ((wc - 0x10000) >> 10); + ucs4_t wc2 = 0xdc00 + ((wc - 0x10000) & 0x3ff); + r[0] = (unsigned char) (wc1 >> 8); + r[1] = (unsigned char) wc1; + r[2] = (unsigned char) (wc2 >> 8); + r[3] = (unsigned char) wc2; + return 4; + } + else + return RET_TOOSMALL; + } + } + return RET_ILUNI; +} + +/* + * UTF-16LE + */ + +/* Specification: RFC 2781 */ + +static int +utf16le_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n) +{ + if (n >= 2) + { + ucs4_t wc = s[0] + (s[1] << 8); + if (wc >= 0xd800 && wc < 0xdc00) + { + if (n >= 4) + { + ucs4_t wc2 = s[2] + (s[3] << 8); + if (!(wc2 >= 0xdc00 && wc2 < 0xe000)) + return RET_ILSEQ; + *pwc = 0x10000 + ((wc - 0xd800) << 10) + (wc2 - 0xdc00); + return 4; + } + } + else if (wc >= 0xdc00 && wc < 0xe000) + { + return RET_ILSEQ; + } + else + { + *pwc = wc; + return 2; + } + } + return RET_TOOFEW; +} + +static int +utf16le_wctomb (unsigned char *r, ucs4_t wc, size_t n) +{ + if (!(wc >= 0xd800 && wc < 0xe000)) + { + if (wc < 0x10000) + { + if (n >= 2) + { + r[0] = (unsigned char) wc; + r[1] = (unsigned char) (wc >> 8); + return 2; + } + else + return RET_TOOSMALL; + } + else if (wc < 0x110000) + { + if (n >= 4) + { + ucs4_t wc1 = 0xd800 + ((wc - 0x10000) >> 10); + ucs4_t wc2 = 0xdc00 + ((wc - 0x10000) & 0x3ff); + r[0] = (unsigned char) wc1; + r[1] = (unsigned char) (wc1 >> 8); + r[2] = (unsigned char) wc2; + r[3] = (unsigned char) (wc2 >> 8); + return 4; + } + else + return RET_TOOSMALL; + } + } + return RET_ILUNI; +} + +/* + * UTF-32BE + */ + +/* Specification: Unicode 3.1 Standard Annex #19 */ + +static int +utf32be_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n) +{ + if (n >= 4) + { + ucs4_t wc = (s[0] << 24) + (s[1] << 16) + (s[2] << 8) + s[3]; + if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000)) + { + *pwc = wc; + return 4; + } + else + return RET_ILSEQ; + } + return RET_TOOFEW; +} + +static int +utf32be_wctomb (unsigned char *r, ucs4_t wc, size_t n) +{ + if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000)) + { + if (n >= 4) + { + r[0] = 0; + r[1] = (unsigned char) (wc >> 16); + r[2] = (unsigned char) (wc >> 8); + r[3] = (unsigned char) wc; + return 4; + } + else + return RET_TOOSMALL; + } + return RET_ILUNI; +} + +/* + * UTF-32LE + */ + +/* Specification: Unicode 3.1 Standard Annex #19 */ + +static int +utf32le_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n) +{ + if (n >= 4) + { + ucs4_t wc = s[0] + (s[1] << 8) + (s[2] << 16) + (s[3] << 24); + if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000)) + { + *pwc = wc; + return 4; + } + else + return RET_ILSEQ; + } + return RET_TOOFEW; +} + +static int +utf32le_wctomb (unsigned char *r, ucs4_t wc, size_t n) +{ + if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000)) + { + if (n >= 4) + { + r[0] = (unsigned char) wc; + r[1] = (unsigned char) (wc >> 8); + r[2] = (unsigned char) (wc >> 16); + r[3] = 0; + return 4; + } + else + return RET_TOOSMALL; + } + return RET_ILUNI; +} + +#endif + +size_t +rpl_iconv (iconv_t cd, + ICONV_CONST char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft) +#undef iconv +{ +#if REPLACE_ICONV_UTF + switch ((uintptr_t) cd) + { + { + int (*xxx_wctomb) (unsigned char *, ucs4_t, size_t); + + case (uintptr_t) _ICONV_UTF8_UTF16BE: + xxx_wctomb = utf16be_wctomb; + goto loop_from_utf8; + case (uintptr_t) _ICONV_UTF8_UTF16LE: + xxx_wctomb = utf16le_wctomb; + goto loop_from_utf8; + case (uintptr_t) _ICONV_UTF8_UTF32BE: + xxx_wctomb = utf32be_wctomb; + goto loop_from_utf8; + case (uintptr_t) _ICONV_UTF8_UTF32LE: + xxx_wctomb = utf32le_wctomb; + goto loop_from_utf8; + + loop_from_utf8: + if (inbuf == NULL || *inbuf == NULL) + return 0; + { + ICONV_CONST char *inptr = *inbuf; + size_t inleft = *inbytesleft; + char *outptr = *outbuf; + size_t outleft = *outbytesleft; + size_t res = 0; + while (inleft > 0) + { + ucs4_t uc; + int m = u8_mbtoucr (&uc, (const uint8_t *) inptr, inleft); + if (m <= 0) + { + if (m == -1) + { + errno = EILSEQ; + res = (size_t)(-1); + break; + } + if (m == -2) + { + errno = EINVAL; + res = (size_t)(-1); + break; + } + abort (); + } + else + { + int n = xxx_wctomb ((uint8_t *) outptr, uc, outleft); + if (n < 0) + { + if (n == RET_ILUNI) + { + errno = EILSEQ; + res = (size_t)(-1); + break; + } + if (n == RET_TOOSMALL) + { + errno = E2BIG; + res = (size_t)(-1); + break; + } + abort (); + } + else + { + inptr += m; + inleft -= m; + outptr += n; + outleft -= n; + } + } + } + *inbuf = inptr; + *inbytesleft = inleft; + *outbuf = outptr; + *outbytesleft = outleft; + return res; + } + } + + { + int (*xxx_mbtowc) (ucs4_t *, const unsigned char *, size_t); + + case (uintptr_t) _ICONV_UTF16BE_UTF8: + xxx_mbtowc = utf16be_mbtowc; + goto loop_to_utf8; + case (uintptr_t) _ICONV_UTF16LE_UTF8: + xxx_mbtowc = utf16le_mbtowc; + goto loop_to_utf8; + case (uintptr_t) _ICONV_UTF32BE_UTF8: + xxx_mbtowc = utf32be_mbtowc; + goto loop_to_utf8; + case (uintptr_t) _ICONV_UTF32LE_UTF8: + xxx_mbtowc = utf32le_mbtowc; + goto loop_to_utf8; + + loop_to_utf8: + if (inbuf == NULL || *inbuf == NULL) + return 0; + { + ICONV_CONST char *inptr = *inbuf; + size_t inleft = *inbytesleft; + char *outptr = *outbuf; + size_t outleft = *outbytesleft; + size_t res = 0; + while (inleft > 0) + { + ucs4_t uc; + int m = xxx_mbtowc (&uc, (const uint8_t *) inptr, inleft); + if (m <= 0) + { + if (m == RET_ILSEQ) + { + errno = EILSEQ; + res = (size_t)(-1); + break; + } + if (m == RET_TOOFEW) + { + errno = EINVAL; + res = (size_t)(-1); + break; + } + abort (); + } + else + { + int n = u8_uctomb ((uint8_t *) outptr, uc, outleft); + if (n < 0) + { + if (n == -1) + { + errno = EILSEQ; + res = (size_t)(-1); + break; + } + if (n == -2) + { + errno = E2BIG; + res = (size_t)(-1); + break; + } + abort (); + } + else + { + inptr += m; + inleft -= m; + outptr += n; + outleft -= n; + } + } + } + *inbuf = inptr; + *inbytesleft = inleft; + *outbuf = outptr; + *outbytesleft = outleft; + return res; + } + } + } +#endif + return iconv (cd, inbuf, inbytesleft, outbuf, outbytesleft); +} diff --git a/lib/iconv.in.h b/lib/iconv.in.h new file mode 100644 index 000000000..915dce2e7 --- /dev/null +++ b/lib/iconv.in.h @@ -0,0 +1,71 @@ +/* A GNU-like . + + Copyright (C) 2007-2008 Free Software Foundation, Inc. + + This program is free software; you can redistribute 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, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _GL_ICONV_H + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_ICONV_H@ + +#ifndef _GL_ICONV_H +#define _GL_ICONV_H + +#ifdef __cplusplus +extern "C" { +#endif + + +#if @REPLACE_ICONV_OPEN@ +/* An iconv_open wrapper that supports the IANA standardized encoding names + ("ISO-8859-1" etc.) as far as possible. */ +# define iconv_open rpl_iconv_open +extern iconv_t iconv_open (const char *tocode, const char *fromcode); +#endif + +#if @REPLACE_ICONV_UTF@ +/* Special constants for supporting UTF-{16,32}{BE,LE} encodings. + Not public. */ +# define _ICONV_UTF8_UTF16BE (iconv_t)(-161) +# define _ICONV_UTF8_UTF16LE (iconv_t)(-162) +# define _ICONV_UTF8_UTF32BE (iconv_t)(-163) +# define _ICONV_UTF8_UTF32LE (iconv_t)(-164) +# define _ICONV_UTF16BE_UTF8 (iconv_t)(-165) +# define _ICONV_UTF16LE_UTF8 (iconv_t)(-166) +# define _ICONV_UTF32BE_UTF8 (iconv_t)(-167) +# define _ICONV_UTF32LE_UTF8 (iconv_t)(-168) +#endif + +#if @REPLACE_ICONV@ +# define iconv rpl_iconv +extern size_t iconv (iconv_t cd, + @ICONV_CONST@ char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft); +# define iconv_close rpl_iconv_close +extern int iconv_close (iconv_t cd); +#endif + + +#ifdef __cplusplus +} +#endif + +#endif /* _GL_ICONV_H */ +#endif /* _GL_ICONV_H */ diff --git a/lib/iconv_close.c b/lib/iconv_close.c new file mode 100644 index 000000000..3680412a0 --- /dev/null +++ b/lib/iconv_close.c @@ -0,0 +1,47 @@ +/* Character set conversion. + Copyright (C) 2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute 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, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include + +#include +#ifndef uintptr_t +# define uintptr_t unsigned long +#endif + +int +rpl_iconv_close (iconv_t cd) +#undef iconv_close +{ +#if REPLACE_ICONV_UTF + switch ((uintptr_t) cd) + { + case (uintptr_t) _ICONV_UTF8_UTF16BE: + case (uintptr_t) _ICONV_UTF8_UTF16LE: + case (uintptr_t) _ICONV_UTF8_UTF32BE: + case (uintptr_t) _ICONV_UTF8_UTF32LE: + case (uintptr_t) _ICONV_UTF16BE_UTF8: + case (uintptr_t) _ICONV_UTF16LE_UTF8: + case (uintptr_t) _ICONV_UTF32BE_UTF8: + case (uintptr_t) _ICONV_UTF32LE_UTF8: + return 0; + } +#endif + return iconv_close (cd); +} diff --git a/lib/iconv_open-aix.gperf b/lib/iconv_open-aix.gperf new file mode 100644 index 000000000..6782b9956 --- /dev/null +++ b/lib/iconv_open-aix.gperf @@ -0,0 +1,44 @@ +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; +%struct-type +%language=ANSI-C +%define slot-name standard_name +%define hash-function-name mapping_hash +%define lookup-function-name mapping_lookup +%readonly-tables +%global-table +%define word-array-name mappings +%pic +%% +# On AIX 5.1, look in /usr/lib/nls/loc/uconvTable. +ISO-8859-1, "ISO8859-1" +ISO-8859-2, "ISO8859-2" +ISO-8859-3, "ISO8859-3" +ISO-8859-4, "ISO8859-4" +ISO-8859-5, "ISO8859-5" +ISO-8859-6, "ISO8859-6" +ISO-8859-7, "ISO8859-7" +ISO-8859-8, "ISO8859-8" +ISO-8859-9, "ISO8859-9" +ISO-8859-15, "ISO8859-15" +CP437, "IBM-437" +CP850, "IBM-850" +CP852, "IBM-852" +CP856, "IBM-856" +CP857, "IBM-857" +CP861, "IBM-861" +CP865, "IBM-865" +CP869, "IBM-869" +ISO-8859-13, "IBM-921" +CP922, "IBM-922" +CP932, "IBM-932" +CP943, "IBM-943" +CP1046, "IBM-1046" +CP1124, "IBM-1124" +CP1125, "IBM-1125" +CP1129, "IBM-1129" +CP1252, "IBM-1252" +GB2312, "IBM-eucCN" +EUC-JP, "IBM-eucJP" +EUC-KR, "IBM-eucKR" +EUC-TW, "IBM-eucTW" +BIG5, "big5" diff --git a/lib/iconv_open-hpux.gperf b/lib/iconv_open-hpux.gperf new file mode 100644 index 000000000..5a35c83e1 --- /dev/null +++ b/lib/iconv_open-hpux.gperf @@ -0,0 +1,56 @@ +struct mapping { int standard_name; const char vendor_name[9 + 1]; }; +%struct-type +%language=ANSI-C +%define slot-name standard_name +%define hash-function-name mapping_hash +%define lookup-function-name mapping_lookup +%readonly-tables +%global-table +%define word-array-name mappings +%pic +%% +# On HP-UX 11.11, look in /usr/lib/nls/iconv. +ISO-8859-1, "iso88591" +ISO-8859-2, "iso88592" +ISO-8859-5, "iso88595" +ISO-8859-6, "iso88596" +ISO-8859-7, "iso88597" +ISO-8859-8, "iso88598" +ISO-8859-9, "iso88599" +ISO-8859-15, "iso885915" +CP437, "cp437" +CP775, "cp775" +CP850, "cp850" +CP852, "cp852" +CP855, "cp855" +CP857, "cp857" +CP861, "cp861" +CP862, "cp862" +CP864, "cp864" +CP865, "cp865" +CP866, "cp866" +CP869, "cp869" +CP874, "cp874" +CP1250, "cp1250" +CP1251, "cp1251" +CP1252, "cp1252" +CP1253, "cp1253" +CP1254, "cp1254" +CP1255, "cp1255" +CP1256, "cp1256" +CP1257, "cp1257" +CP1258, "cp1258" +HP-ROMAN8, "roman8" +HP-ARABIC8, "arabic8" +HP-GREEK8, "greek8" +HP-HEBREW8, "hebrew8" +HP-TURKISH8, "turkish8" +HP-KANA8, "kana8" +TIS-620, "tis620" +GB2312, "hp15CN" +EUC-JP, "eucJP" +EUC-KR, "eucKR" +EUC-TW, "eucTW" +BIG5, "big5" +SHIFT_JIS, "sjis" +UTF-8, "utf8" diff --git a/lib/iconv_open-irix.gperf b/lib/iconv_open-irix.gperf new file mode 100644 index 000000000..3672a8013 --- /dev/null +++ b/lib/iconv_open-irix.gperf @@ -0,0 +1,31 @@ +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; +%struct-type +%language=ANSI-C +%define slot-name standard_name +%define hash-function-name mapping_hash +%define lookup-function-name mapping_lookup +%readonly-tables +%global-table +%define word-array-name mappings +%pic +%% +# On IRIX 6.5, look in /usr/lib/iconv and /usr/lib/international/encodings. +ISO-8859-1, "ISO8859-1" +ISO-8859-2, "ISO8859-2" +ISO-8859-3, "ISO8859-3" +ISO-8859-4, "ISO8859-4" +ISO-8859-5, "ISO8859-5" +ISO-8859-6, "ISO8859-6" +ISO-8859-7, "ISO8859-7" +ISO-8859-8, "ISO8859-8" +ISO-8859-9, "ISO8859-9" +ISO-8859-15, "ISO8859-15" +KOI8-R, "KOI8" +CP855, "DOS855" +CP1251, "WIN1251" +GB2312, "eucCN" +EUC-JP, "eucJP" +EUC-KR, "eucKR" +EUC-TW, "eucTW" +SHIFT_JIS, "sjis" +TIS-620, "TIS620" diff --git a/lib/iconv_open-osf.gperf b/lib/iconv_open-osf.gperf new file mode 100644 index 000000000..f468ff609 --- /dev/null +++ b/lib/iconv_open-osf.gperf @@ -0,0 +1,50 @@ +struct mapping { int standard_name; const char vendor_name[10 + 1]; }; +%struct-type +%language=ANSI-C +%define slot-name standard_name +%define hash-function-name mapping_hash +%define lookup-function-name mapping_lookup +%readonly-tables +%global-table +%define word-array-name mappings +%pic +%% +# On OSF/1 5.1, look in /usr/lib/nls/loc/iconv. +ISO-8859-1, "ISO8859-1" +ISO-8859-2, "ISO8859-2" +ISO-8859-3, "ISO8859-3" +ISO-8859-4, "ISO8859-4" +ISO-8859-5, "ISO8859-5" +ISO-8859-6, "ISO8859-6" +ISO-8859-7, "ISO8859-7" +ISO-8859-8, "ISO8859-8" +ISO-8859-9, "ISO8859-9" +ISO-8859-15, "ISO8859-15" +CP437, "cp437" +CP775, "cp775" +CP850, "cp850" +CP852, "cp852" +CP855, "cp855" +CP857, "cp857" +CP861, "cp861" +CP862, "cp862" +CP865, "cp865" +CP866, "cp866" +CP869, "cp869" +CP874, "cp874" +CP949, "KSC5601" +CP1250, "cp1250" +CP1251, "cp1251" +CP1252, "cp1252" +CP1253, "cp1253" +CP1254, "cp1254" +CP1255, "cp1255" +CP1256, "cp1256" +CP1257, "cp1257" +CP1258, "cp1258" +EUC-JP, "eucJP" +EUC-KR, "eucKR" +EUC-TW, "eucTW" +BIG5, "big5" +SHIFT_JIS, "SJIS" +TIS-620, "TACTIS" diff --git a/lib/iconv_open.c b/lib/iconv_open.c new file mode 100644 index 000000000..3d873acd6 --- /dev/null +++ b/lib/iconv_open.c @@ -0,0 +1,172 @@ +/* Character set conversion. + Copyright (C) 2007 Free Software Foundation, Inc. + + This program is free software; you can redistribute 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, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#include + +/* Specification. */ +#include + +#include +#include +#include "c-ctype.h" +#include "c-strcase.h" + +#define SIZEOF(a) (sizeof(a) / sizeof(a[0])) + +/* Namespace cleanliness. */ +#define mapping_lookup rpl_iconv_open_mapping_lookup + +/* The macro ICONV_FLAVOR is defined to one of these or undefined. */ + +#define ICONV_FLAVOR_AIX "iconv_open-aix.h" +#define ICONV_FLAVOR_HPUX "iconv_open-hpux.h" +#define ICONV_FLAVOR_IRIX "iconv_open-irix.h" +#define ICONV_FLAVOR_OSF "iconv_open-osf.h" + +#ifdef ICONV_FLAVOR +# include ICONV_FLAVOR +#endif + +iconv_t +rpl_iconv_open (const char *tocode, const char *fromcode) +#undef iconv_open +{ + char fromcode_upper[32]; + char tocode_upper[32]; + char *fromcode_upper_end; + char *tocode_upper_end; + +#if REPLACE_ICONV_UTF + /* Special handling of conversion between UTF-8 and UTF-{16,32}{BE,LE}. + Do this here, before calling the real iconv_open(), because OSF/1 5.1 + iconv() to these encoding inserts a BOM, which is wrong. + We do not need to handle conversion between arbitrary encodings and + UTF-{16,32}{BE,LE}, because the 'striconveh' module implements two-step + conversion throough UTF-8. + The _ICONV_* constants are chosen to be disjoint from any iconv_t + returned by the system's iconv_open() functions. Recall that iconv_t + is a scalar type. */ + if (c_toupper (fromcode[0]) == 'U' + && c_toupper (fromcode[1]) == 'T' + && c_toupper (fromcode[2]) == 'F' + && fromcode[3] == '-') + { + if (c_toupper (tocode[0]) == 'U' + && c_toupper (tocode[1]) == 'T' + && c_toupper (tocode[2]) == 'F' + && tocode[3] == '-') + { + if (strcmp (fromcode + 4, "8") == 0) + { + if (c_strcasecmp (tocode + 4, "16BE") == 0) + return _ICONV_UTF8_UTF16BE; + if (c_strcasecmp (tocode + 4, "16LE") == 0) + return _ICONV_UTF8_UTF16LE; + if (c_strcasecmp (tocode + 4, "32BE") == 0) + return _ICONV_UTF8_UTF32BE; + if (c_strcasecmp (tocode + 4, "32LE") == 0) + return _ICONV_UTF8_UTF32LE; + } + else if (strcmp (tocode + 4, "8") == 0) + { + if (c_strcasecmp (fromcode + 4, "16BE") == 0) + return _ICONV_UTF16BE_UTF8; + if (c_strcasecmp (fromcode + 4, "16LE") == 0) + return _ICONV_UTF16LE_UTF8; + if (c_strcasecmp (fromcode + 4, "32BE") == 0) + return _ICONV_UTF32BE_UTF8; + if (c_strcasecmp (fromcode + 4, "32LE") == 0) + return _ICONV_UTF32LE_UTF8; + } + } + } +#endif + + /* Do *not* add special support for 8-bit encodings like ASCII or ISO-8859-1 + here. This would lead to programs that work in some locales (such as the + "C" or "en_US" locales) but do not work in East Asian locales. It is + better if programmers make their programs depend on GNU libiconv (except + on glibc systems), e.g. by using the AM_ICONV macro and documenting the + dependency in an INSTALL or DEPENDENCIES file. */ + + /* Try with the original names first. + This covers the case when fromcode or tocode is a lowercase encoding name + that is understood by the system's iconv_open but not listed in our + mappings table. */ + { + iconv_t cd = iconv_open (tocode, fromcode); + if (cd != (iconv_t)(-1)) + return cd; + } + + /* Convert the encodings to upper case, because + 1. in the arguments of iconv_open() on AIX, HP-UX, and OSF/1 the case + matters, + 2. it makes searching in the table faster. */ + { + const char *p = fromcode; + char *q = fromcode_upper; + while ((*q = c_toupper (*p)) != '\0') + { + p++; + q++; + if (q == &fromcode_upper[SIZEOF (fromcode_upper)]) + { + errno = EINVAL; + return (iconv_t)(-1); + } + } + fromcode_upper_end = q; + } + + { + const char *p = tocode; + char *q = tocode_upper; + while ((*q = c_toupper (*p)) != '\0') + { + p++; + q++; + if (q == &tocode_upper[SIZEOF (tocode_upper)]) + { + errno = EINVAL; + return (iconv_t)(-1); + } + } + tocode_upper_end = q; + } + +#ifdef ICONV_FLAVOR + /* Apply the mappings. */ + { + const struct mapping *m = + mapping_lookup (fromcode_upper, fromcode_upper_end - fromcode_upper); + + fromcode = (m != NULL ? m->vendor_name : fromcode_upper); + } + { + const struct mapping *m = + mapping_lookup (tocode_upper, tocode_upper_end - tocode_upper); + + tocode = (m != NULL ? m->vendor_name : tocode_upper); + } +#else + fromcode = fromcode_upper; + tocode = tocode_upper; +#endif + + return iconv_open (tocode, fromcode); +} diff --git a/lib/iconveh.h b/lib/iconveh.h new file mode 100644 index 000000000..06cda52e8 --- /dev/null +++ b/lib/iconveh.h @@ -0,0 +1,41 @@ +/* Character set conversion handler type. + Copyright (C) 2001-2007, 2009 Free Software Foundation, Inc. + Written by Bruno Haible. + + This program is free software: you can redistribute 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 _ICONVEH_H +#define _ICONVEH_H + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Handling of unconvertible characters. */ +enum iconv_ilseq_handler +{ + iconveh_error, /* return and set errno = EILSEQ */ + iconveh_question_mark, /* use one '?' per unconvertible character */ + iconveh_escape_sequence /* use escape sequence \uxxxx or \Uxxxxxxxx */ +}; + + +#ifdef __cplusplus +} +#endif + + +#endif /* _ICONVEH_H */ diff --git a/lib/striconveh.c b/lib/striconveh.c new file mode 100644 index 000000000..b39a01f19 --- /dev/null +++ b/lib/striconveh.c @@ -0,0 +1,1251 @@ +/* Character set conversion with error handling. + Copyright (C) 2001-2008 Free Software Foundation, Inc. + Written by Bruno Haible and Simon Josefsson. + + This program is free software: you can redistribute 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 "striconveh.h" + +#include +#include +#include +#include + +#if HAVE_ICONV +# include +# include "unistr.h" +#endif + +#include "c-strcase.h" +#include "c-strcaseeq.h" + +#ifndef SIZE_MAX +# define SIZE_MAX ((size_t) -1) +#endif + + +#if HAVE_ICONV + +/* The caller must provide CD, CD1, CD2, not just CD, because when a conversion + error occurs, we may have to determine the Unicode representation of the + inconvertible character. */ + +/* iconv_carefully is like iconv, except that it stops as soon as it encounters + a conversion error, and it returns in *INCREMENTED a boolean telling whether + it has incremented the input pointers past the error location. */ +# if !defined _LIBICONV_VERSION && !defined __GLIBC__ +/* Irix iconv() inserts a NUL byte if it cannot convert. + NetBSD iconv() inserts a question mark if it cannot convert. + Only GNU libiconv and GNU libc are known to prefer to fail rather + than doing a lossy conversion. */ +static size_t +iconv_carefully (iconv_t cd, + const char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft, + bool *incremented) +{ + const char *inptr = *inbuf; + const char *inptr_end = inptr + *inbytesleft; + char *outptr = *outbuf; + size_t outsize = *outbytesleft; + const char *inptr_before; + size_t res; + + do + { + size_t insize; + + inptr_before = inptr; + res = (size_t)(-1); + + for (insize = 1; inptr + insize <= inptr_end; insize++) + { + res = iconv (cd, + (ICONV_CONST char **) &inptr, &insize, + &outptr, &outsize); + if (!(res == (size_t)(-1) && errno == EINVAL)) + break; + /* iconv can eat up a shift sequence but give EINVAL while attempting + to convert the first character. E.g. libiconv does this. */ + if (inptr > inptr_before) + { + res = 0; + break; + } + } + + if (res == 0) + { + *outbuf = outptr; + *outbytesleft = outsize; + } + } + while (res == 0 && inptr < inptr_end); + + *inbuf = inptr; + *inbytesleft = inptr_end - inptr; + if (res != (size_t)(-1) && res > 0) + { + /* iconv() has already incremented INPTR. We cannot go back to a + previous INPTR, otherwise the state inside CD would become invalid, + if FROM_CODESET is a stateful encoding. So, tell the caller that + *INBUF has already been incremented. */ + *incremented = (inptr > inptr_before); + errno = EILSEQ; + return (size_t)(-1); + } + else + { + *incremented = false; + return res; + } +} +# else +# define iconv_carefully(cd, inbuf, inbytesleft, outbuf, outbytesleft, incremented) \ + (*(incremented) = false, \ + iconv (cd, (ICONV_CONST char **) (inbuf), inbytesleft, outbuf, outbytesleft)) +# endif + +/* iconv_carefully_1 is like iconv_carefully, except that it stops after + converting one character or one shift sequence. */ +static size_t +iconv_carefully_1 (iconv_t cd, + const char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft, + bool *incremented) +{ + const char *inptr_before = *inbuf; + const char *inptr = inptr_before; + const char *inptr_end = inptr_before + *inbytesleft; + char *outptr = *outbuf; + size_t outsize = *outbytesleft; + size_t res = (size_t)(-1); + size_t insize; + + for (insize = 1; inptr_before + insize <= inptr_end; insize++) + { + inptr = inptr_before; + res = iconv (cd, + (ICONV_CONST char **) &inptr, &insize, + &outptr, &outsize); + if (!(res == (size_t)(-1) && errno == EINVAL)) + break; + /* iconv can eat up a shift sequence but give EINVAL while attempting + to convert the first character. E.g. libiconv does this. */ + if (inptr > inptr_before) + { + res = 0; + break; + } + } + + *inbuf = inptr; + *inbytesleft = inptr_end - inptr; +# if !defined _LIBICONV_VERSION && !defined __GLIBC__ + /* Irix iconv() inserts a NUL byte if it cannot convert. + NetBSD iconv() inserts a question mark if it cannot convert. + Only GNU libiconv and GNU libc are known to prefer to fail rather + than doing a lossy conversion. */ + if (res != (size_t)(-1) && res > 0) + { + /* iconv() has already incremented INPTR. We cannot go back to a + previous INPTR, otherwise the state inside CD would become invalid, + if FROM_CODESET is a stateful encoding. So, tell the caller that + *INBUF has already been incremented. */ + *incremented = (inptr > inptr_before); + errno = EILSEQ; + return (size_t)(-1); + } +# endif + + if (res != (size_t)(-1)) + { + *outbuf = outptr; + *outbytesleft = outsize; + } + *incremented = false; + return res; +} + +/* utf8conv_carefully is like iconv, except that + - it converts from UTF-8 to UTF-8, + - it stops as soon as it encounters a conversion error, and it returns + in *INCREMENTED a boolean telling whether it has incremented the input + pointers past the error location, + - if one_character_only is true, it stops after converting one + character. */ +static size_t +utf8conv_carefully (bool one_character_only, + const char **inbuf, size_t *inbytesleft, + char **outbuf, size_t *outbytesleft, + bool *incremented) +{ + const char *inptr = *inbuf; + size_t insize = *inbytesleft; + char *outptr = *outbuf; + size_t outsize = *outbytesleft; + size_t res; + + res = 0; + do + { + ucs4_t uc; + int n; + int m; + + n = u8_mbtoucr (&uc, (const uint8_t *) inptr, insize); + if (n < 0) + { + errno = (n == -2 ? EINVAL : EILSEQ); + n = u8_mbtouc (&uc, (const uint8_t *) inptr, insize); + inptr += n; + insize -= n; + res = (size_t)(-1); + *incremented = true; + break; + } + if (outsize == 0) + { + errno = E2BIG; + res = (size_t)(-1); + *incremented = false; + break; + } + m = u8_uctomb ((uint8_t *) outptr, uc, outsize); + if (m == -2) + { + errno = E2BIG; + res = (size_t)(-1); + *incremented = false; + break; + } + inptr += n; + insize -= n; + if (m == -1) + { + errno = EILSEQ; + res = (size_t)(-1); + *incremented = true; + break; + } + outptr += m; + outsize -= m; + } + while (!one_character_only && insize > 0); + + *inbuf = inptr; + *inbytesleft = insize; + *outbuf = outptr; + *outbytesleft = outsize; + return res; +} + +static int +mem_cd_iconveh_internal (const char *src, size_t srclen, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler, + size_t extra_alloc, + size_t *offsets, + char **resultp, size_t *lengthp) +{ + /* When a conversion error occurs, we cannot start using CD1 and CD2 at + this point: FROM_CODESET may be a stateful encoding like ISO-2022-KR. + Instead, we have to start afresh from the beginning of SRC. */ + /* Use a temporary buffer, so that for small strings, a single malloc() + call will be sufficient. */ +# define tmpbufsize 4096 + /* The alignment is needed when converting e.g. to glibc's WCHAR_T or + libiconv's UCS-4-INTERNAL encoding. */ + union { unsigned int align; char buf[tmpbufsize]; } tmp; +# define tmpbuf tmp.buf + + char *initial_result; + char *result; + size_t allocated; + size_t length; + size_t last_length = (size_t)(-1); /* only needed if offsets != NULL */ + + if (*resultp != NULL && *lengthp >= sizeof (tmpbuf)) + { + initial_result = *resultp; + allocated = *lengthp; + } + else + { + initial_result = tmpbuf; + allocated = sizeof (tmpbuf); + } + result = initial_result; + + /* Test whether a direct conversion is possible at all. */ + if (cd == (iconv_t)(-1)) + goto indirectly; + + if (offsets != NULL) + { + size_t i; + + for (i = 0; i < srclen; i++) + offsets[i] = (size_t)(-1); + + last_length = (size_t)(-1); + } + length = 0; + + /* First, try a direct conversion, and see whether a conversion error + occurs at all. */ + { + const char *inptr = src; + size_t insize = srclen; + + /* Avoid glibc-2.1 bug and Solaris 2.7-2.9 bug. */ +# if defined _LIBICONV_VERSION \ + || !((__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) || defined __sun) + /* Set to the initial state. */ + iconv (cd, NULL, NULL, NULL, NULL); +# endif + + while (insize > 0) + { + char *outptr = result + length; + size_t outsize = allocated - extra_alloc - length; + bool incremented; + size_t res; + bool grow; + + if (offsets != NULL) + { + if (length != last_length) /* ensure that offset[] be increasing */ + { + offsets[inptr - src] = length; + last_length = length; + } + res = iconv_carefully_1 (cd, + &inptr, &insize, + &outptr, &outsize, + &incremented); + } + else + /* Use iconv_carefully instead of iconv here, because: + - If TO_CODESET is UTF-8, we can do the error handling in this + loop, no need for a second loop, + - With iconv() implementations other than GNU libiconv and GNU + libc, if we use iconv() in a big swoop, checking for an E2BIG + return, we lose the number of irreversible conversions. */ + res = iconv_carefully (cd, + &inptr, &insize, + &outptr, &outsize, + &incremented); + + length = outptr - result; + grow = (length + extra_alloc > allocated / 2); + if (res == (size_t)(-1)) + { + if (errno == E2BIG) + grow = true; + else if (errno == EINVAL) + break; + else if (errno == EILSEQ && handler != iconveh_error) + { + if (cd2 == (iconv_t)(-1)) + { + /* TO_CODESET is UTF-8. */ + /* Error handling can produce up to 1 byte of output. */ + if (length + 1 + extra_alloc > allocated) + { + char *memory; + + allocated = 2 * allocated; + if (length + 1 + extra_alloc > allocated) + abort (); + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + grow = false; + } + /* The input is invalid in FROM_CODESET. Eat up one byte + and emit a question mark. */ + if (!incremented) + { + if (insize == 0) + abort (); + inptr++; + insize--; + } + result[length] = '?'; + length++; + } + else + goto indirectly; + } + else + { + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + } + if (insize == 0) + break; + if (grow) + { + char *memory; + + allocated = 2 * allocated; + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + } + } + } + + /* Now get the conversion state back to the initial state. + But avoid glibc-2.1 bug and Solaris 2.7 bug. */ +#if defined _LIBICONV_VERSION \ + || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun) + for (;;) + { + char *outptr = result + length; + size_t outsize = allocated - extra_alloc - length; + size_t res; + + res = iconv (cd, NULL, NULL, &outptr, &outsize); + length = outptr - result; + if (res == (size_t)(-1)) + { + if (errno == E2BIG) + { + char *memory; + + allocated = 2 * allocated; + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + } + else + { + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + } + else + break; + } +#endif + + /* The direct conversion succeeded. */ + goto done; + + indirectly: + /* The direct conversion failed. + Use a conversion through UTF-8. */ + if (offsets != NULL) + { + size_t i; + + for (i = 0; i < srclen; i++) + offsets[i] = (size_t)(-1); + + last_length = (size_t)(-1); + } + length = 0; + { + const bool slowly = (offsets != NULL || handler == iconveh_error); +# define utf8bufsize 4096 /* may also be smaller or larger than tmpbufsize */ + char utf8buf[utf8bufsize + 1]; + size_t utf8len = 0; + const char *in1ptr = src; + size_t in1size = srclen; + bool do_final_flush1 = true; + bool do_final_flush2 = true; + + /* Avoid glibc-2.1 bug and Solaris 2.7-2.9 bug. */ +# if defined _LIBICONV_VERSION \ + || !((__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) || defined __sun) + /* Set to the initial state. */ + if (cd1 != (iconv_t)(-1)) + iconv (cd1, NULL, NULL, NULL, NULL); + if (cd2 != (iconv_t)(-1)) + iconv (cd2, NULL, NULL, NULL, NULL); +# endif + + while (in1size > 0 || do_final_flush1 || utf8len > 0 || do_final_flush2) + { + char *out1ptr = utf8buf + utf8len; + size_t out1size = utf8bufsize - utf8len; + bool incremented1; + size_t res1; + int errno1; + + /* Conversion step 1: from FROM_CODESET to UTF-8. */ + if (in1size > 0) + { + if (offsets != NULL + && length != last_length) /* ensure that offset[] be increasing */ + { + offsets[in1ptr - src] = length; + last_length = length; + } + if (cd1 != (iconv_t)(-1)) + { + if (slowly) + res1 = iconv_carefully_1 (cd1, + &in1ptr, &in1size, + &out1ptr, &out1size, + &incremented1); + else + res1 = iconv_carefully (cd1, + &in1ptr, &in1size, + &out1ptr, &out1size, + &incremented1); + } + else + { + /* FROM_CODESET is UTF-8. */ + res1 = utf8conv_carefully (slowly, + &in1ptr, &in1size, + &out1ptr, &out1size, + &incremented1); + } + } + else if (do_final_flush1) + { + /* Now get the conversion state of CD1 back to the initial state. + But avoid glibc-2.1 bug and Solaris 2.7 bug. */ +# if defined _LIBICONV_VERSION \ + || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun) + if (cd1 != (iconv_t)(-1)) + res1 = iconv (cd1, NULL, NULL, &out1ptr, &out1size); + else +# endif + res1 = 0; + do_final_flush1 = false; + incremented1 = true; + } + else + { + res1 = 0; + incremented1 = true; + } + if (res1 == (size_t)(-1) + && !(errno == E2BIG || errno == EINVAL || errno == EILSEQ)) + { + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + if (res1 == (size_t)(-1) + && errno == EILSEQ && handler != iconveh_error) + { + /* The input is invalid in FROM_CODESET. Eat up one byte and + emit a question mark. Room for the question mark was allocated + at the end of utf8buf. */ + if (!incremented1) + { + if (in1size == 0) + abort (); + in1ptr++; + in1size--; + } + utf8buf[utf8len++] = '?'; + } + errno1 = errno; + utf8len = out1ptr - utf8buf; + + if (offsets != NULL + || in1size == 0 + || utf8len > utf8bufsize / 2 + || (res1 == (size_t)(-1) && errno1 == E2BIG)) + { + /* Conversion step 2: from UTF-8 to TO_CODESET. */ + const char *in2ptr = utf8buf; + size_t in2size = utf8len; + + while (in2size > 0 + || (in1size == 0 && !do_final_flush1 && do_final_flush2)) + { + char *out2ptr = result + length; + size_t out2size = allocated - extra_alloc - length; + bool incremented2; + size_t res2; + bool grow; + + if (in2size > 0) + { + if (cd2 != (iconv_t)(-1)) + res2 = iconv_carefully (cd2, + &in2ptr, &in2size, + &out2ptr, &out2size, + &incremented2); + else + /* TO_CODESET is UTF-8. */ + res2 = utf8conv_carefully (false, + &in2ptr, &in2size, + &out2ptr, &out2size, + &incremented2); + } + else /* in1size == 0 && !do_final_flush1 + && in2size == 0 && do_final_flush2 */ + { + /* Now get the conversion state of CD1 back to the initial + state. But avoid glibc-2.1 bug and Solaris 2.7 bug. */ +# if defined _LIBICONV_VERSION \ + || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun) + if (cd2 != (iconv_t)(-1)) + res2 = iconv (cd2, NULL, NULL, &out2ptr, &out2size); + else +# endif + res2 = 0; + do_final_flush2 = false; + incremented2 = true; + } + + length = out2ptr - result; + grow = (length + extra_alloc > allocated / 2); + if (res2 == (size_t)(-1)) + { + if (errno == E2BIG) + grow = true; + else if (errno == EINVAL) + break; + else if (errno == EILSEQ && handler != iconveh_error) + { + /* Error handling can produce up to 10 bytes of ASCII + output. But TO_CODESET may be UCS-2, UTF-16 or + UCS-4, so use CD2 here as well. */ + char scratchbuf[10]; + size_t scratchlen; + ucs4_t uc; + const char *inptr; + size_t insize; + size_t res; + + if (incremented2) + { + if (u8_prev (&uc, (const uint8_t *) in2ptr, + (const uint8_t *) utf8buf) + == NULL) + abort (); + } + else + { + int n; + if (in2size == 0) + abort (); + n = u8_mbtouc_unsafe (&uc, (const uint8_t *) in2ptr, + in2size); + in2ptr += n; + in2size -= n; + } + + if (handler == iconveh_escape_sequence) + { + static char hex[16] = "0123456789ABCDEF"; + scratchlen = 0; + scratchbuf[scratchlen++] = '\\'; + if (uc < 0x10000) + scratchbuf[scratchlen++] = 'u'; + else + { + scratchbuf[scratchlen++] = 'U'; + scratchbuf[scratchlen++] = hex[(uc>>28) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>24) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>20) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>16) & 15]; + } + scratchbuf[scratchlen++] = hex[(uc>>12) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>8) & 15]; + scratchbuf[scratchlen++] = hex[(uc>>4) & 15]; + scratchbuf[scratchlen++] = hex[uc & 15]; + } + else + { + scratchbuf[0] = '?'; + scratchlen = 1; + } + + inptr = scratchbuf; + insize = scratchlen; + if (cd2 != (iconv_t)(-1)) + res = iconv (cd2, + (ICONV_CONST char **) &inptr, &insize, + &out2ptr, &out2size); + else + { + /* TO_CODESET is UTF-8. */ + if (out2size >= insize) + { + memcpy (out2ptr, inptr, insize); + out2ptr += insize; + out2size -= insize; + inptr += insize; + insize = 0; + res = 0; + } + else + { + errno = E2BIG; + res = (size_t)(-1); + } + } + length = out2ptr - result; + if (res == (size_t)(-1) && errno == E2BIG) + { + char *memory; + + allocated = 2 * allocated; + if (length + 1 + extra_alloc > allocated) + abort (); + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + grow = false; + + out2ptr = result + length; + out2size = allocated - extra_alloc - length; + if (cd2 != (iconv_t)(-1)) + res = iconv (cd2, + (ICONV_CONST char **) &inptr, + &insize, + &out2ptr, &out2size); + else + { + /* TO_CODESET is UTF-8. */ + if (!(out2size >= insize)) + abort (); + memcpy (out2ptr, inptr, insize); + out2ptr += insize; + out2size -= insize; + inptr += insize; + insize = 0; + res = 0; + } + length = out2ptr - result; + } +# if !defined _LIBICONV_VERSION && !defined __GLIBC__ + /* Irix iconv() inserts a NUL byte if it cannot convert. + NetBSD iconv() inserts a question mark if it cannot + convert. + Only GNU libiconv and GNU libc are known to prefer + to fail rather than doing a lossy conversion. */ + if (res != (size_t)(-1) && res > 0) + { + errno = EILSEQ; + res = (size_t)(-1); + } +# endif + if (res == (size_t)(-1)) + { + /* Failure converting the ASCII replacement. */ + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + } + else + { + if (result != initial_result) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return -1; + } + } + if (!(in2size > 0 + || (in1size == 0 && !do_final_flush1 && do_final_flush2))) + break; + if (grow) + { + char *memory; + + allocated = 2 * allocated; + if (result == initial_result) + memory = (char *) malloc (allocated); + else + memory = (char *) realloc (result, allocated); + if (memory == NULL) + { + if (result != initial_result) + free (result); + errno = ENOMEM; + return -1; + } + if (result == initial_result) + memcpy (memory, initial_result, length); + result = memory; + } + } + + /* Move the remaining bytes to the beginning of utf8buf. */ + if (in2size > 0) + memmove (utf8buf, in2ptr, in2size); + utf8len = in2size; + } + + if (res1 == (size_t)(-1)) + { + if (errno1 == EINVAL) + in1size = 0; + else if (errno1 == EILSEQ) + { + if (result != initial_result) + free (result); + errno = errno1; + return -1; + } + } + } +# undef utf8bufsize + } + + done: + /* Now the final memory allocation. */ + if (result == tmpbuf) + { + size_t memsize = length + extra_alloc; + char *memory; + + memory = (char *) malloc (memsize > 0 ? memsize : 1); + if (memory != NULL) + { + memcpy (memory, tmpbuf, length); + result = memory; + } + else + { + errno = ENOMEM; + return -1; + } + } + else if (result != *resultp && length + extra_alloc < allocated) + { + /* Shrink the allocated memory if possible. */ + size_t memsize = length + extra_alloc; + char *memory; + + memory = (char *) realloc (result, memsize > 0 ? memsize : 1); + if (memory != NULL) + result = memory; + } + *resultp = result; + *lengthp = length; + return 0; +# undef tmpbuf +# undef tmpbufsize +} + +int +mem_cd_iconveh (const char *src, size_t srclen, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler, + size_t *offsets, + char **resultp, size_t *lengthp) +{ + return mem_cd_iconveh_internal (src, srclen, cd, cd1, cd2, handler, 0, + offsets, resultp, lengthp); +} + +char * +str_cd_iconveh (const char *src, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler) +{ + /* For most encodings, a trailing NUL byte in the input will be converted + to a trailing NUL byte in the output. But not for UTF-7. So that this + function is usable for UTF-7, we have to exclude the NUL byte from the + conversion and add it by hand afterwards. */ + char *result = NULL; + size_t length = 0; + int retval = mem_cd_iconveh_internal (src, strlen (src), + cd, cd1, cd2, handler, 1, NULL, + &result, &length); + + if (retval < 0) + { + if (result != NULL) + { + int saved_errno = errno; + free (result); + errno = saved_errno; + } + return NULL; + } + + /* Add the terminating NUL byte. */ + result[length] = '\0'; + + return result; +} + +#endif + +int +mem_iconveh (const char *src, size_t srclen, + const char *from_codeset, const char *to_codeset, + enum iconv_ilseq_handler handler, + size_t *offsets, + char **resultp, size_t *lengthp) +{ + if (srclen == 0) + { + /* Nothing to convert. */ + *lengthp = 0; + return 0; + } + else if (offsets == NULL && c_strcasecmp (from_codeset, to_codeset) == 0) + { + char *result; + + if (*resultp != NULL && *lengthp >= srclen) + result = *resultp; + else + { + result = (char *) malloc (srclen); + if (result == NULL) + { + errno = ENOMEM; + return -1; + } + } + memcpy (result, src, srclen); + *resultp = result; + *lengthp = srclen; + return 0; + } + else + { +#if HAVE_ICONV + iconv_t cd; + iconv_t cd1; + iconv_t cd2; + char *result; + size_t length; + int retval; + + /* Avoid glibc-2.1 bug with EUC-KR. */ +# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined _LIBICONV_VERSION + if (c_strcasecmp (from_codeset, "EUC-KR") == 0 + || c_strcasecmp (to_codeset, "EUC-KR") == 0) + { + errno = EINVAL; + return -1; + } +# endif + + cd = iconv_open (to_codeset, from_codeset); + + if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)) + cd1 = (iconv_t)(-1); + else + { + cd1 = iconv_open ("UTF-8", from_codeset); + if (cd1 == (iconv_t)(-1)) + { + int saved_errno = errno; + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + return -1; + } + } + + if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0) +# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 || _LIBICONV_VERSION >= 0x0105 + || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0 +# endif + ) + cd2 = (iconv_t)(-1); + else + { + cd2 = iconv_open (to_codeset, "UTF-8"); + if (cd2 == (iconv_t)(-1)) + { + int saved_errno = errno; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + return -1; + } + } + + result = *resultp; + length = *lengthp; + retval = mem_cd_iconveh (src, srclen, cd, cd1, cd2, handler, offsets, + &result, &length); + + if (retval < 0) + { + /* Close cd, cd1, cd2, but preserve the errno from str_cd_iconv. */ + int saved_errno = errno; + if (cd2 != (iconv_t)(-1)) + iconv_close (cd2); + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + } + else + { + if (cd2 != (iconv_t)(-1) && iconv_close (cd2) < 0) + { + /* Return -1, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + if (result != *resultp && result != NULL) + free (result); + errno = saved_errno; + return -1; + } + if (cd1 != (iconv_t)(-1) && iconv_close (cd1) < 0) + { + /* Return -1, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (cd != (iconv_t)(-1)) + iconv_close (cd); + if (result != *resultp && result != NULL) + free (result); + errno = saved_errno; + return -1; + } + if (cd != (iconv_t)(-1) && iconv_close (cd) < 0) + { + /* Return -1, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (result != *resultp && result != NULL) + free (result); + errno = saved_errno; + return -1; + } + *resultp = result; + *lengthp = length; + } + return retval; +#else + /* This is a different error code than if iconv_open existed but didn't + support from_codeset and to_codeset, so that the caller can emit + an error message such as + "iconv() is not supported. Installing GNU libiconv and + then reinstalling this package would fix this." */ + errno = ENOSYS; + return -1; +#endif + } +} + +char * +str_iconveh (const char *src, + const char *from_codeset, const char *to_codeset, + enum iconv_ilseq_handler handler) +{ + if (*src == '\0' || c_strcasecmp (from_codeset, to_codeset) == 0) + { + char *result = strdup (src); + + if (result == NULL) + errno = ENOMEM; + return result; + } + else + { +#if HAVE_ICONV + iconv_t cd; + iconv_t cd1; + iconv_t cd2; + char *result; + + /* Avoid glibc-2.1 bug with EUC-KR. */ +# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined _LIBICONV_VERSION + if (c_strcasecmp (from_codeset, "EUC-KR") == 0 + || c_strcasecmp (to_codeset, "EUC-KR") == 0) + { + errno = EINVAL; + return NULL; + } +# endif + + cd = iconv_open (to_codeset, from_codeset); + + if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)) + cd1 = (iconv_t)(-1); + else + { + cd1 = iconv_open ("UTF-8", from_codeset); + if (cd1 == (iconv_t)(-1)) + { + int saved_errno = errno; + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + return NULL; + } + } + + if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0) +# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 || _LIBICONV_VERSION >= 0x0105 + || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0 +# endif + ) + cd2 = (iconv_t)(-1); + else + { + cd2 = iconv_open (to_codeset, "UTF-8"); + if (cd2 == (iconv_t)(-1)) + { + int saved_errno = errno; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + return NULL; + } + } + + result = str_cd_iconveh (src, cd, cd1, cd2, handler); + + if (result == NULL) + { + /* Close cd, cd1, cd2, but preserve the errno from str_cd_iconv. */ + int saved_errno = errno; + if (cd2 != (iconv_t)(-1)) + iconv_close (cd2); + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + errno = saved_errno; + } + else + { + if (cd2 != (iconv_t)(-1) && iconv_close (cd2) < 0) + { + /* Return NULL, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (cd1 != (iconv_t)(-1)) + iconv_close (cd1); + if (cd != (iconv_t)(-1)) + iconv_close (cd); + free (result); + errno = saved_errno; + return NULL; + } + if (cd1 != (iconv_t)(-1) && iconv_close (cd1) < 0) + { + /* Return NULL, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + if (cd != (iconv_t)(-1)) + iconv_close (cd); + free (result); + errno = saved_errno; + return NULL; + } + if (cd != (iconv_t)(-1) && iconv_close (cd) < 0) + { + /* Return NULL, but free the allocated memory, and while doing + that, preserve the errno from iconv_close. */ + int saved_errno = errno; + free (result); + errno = saved_errno; + return NULL; + } + } + return result; +#else + /* This is a different error code than if iconv_open existed but didn't + support from_codeset and to_codeset, so that the caller can emit + an error message such as + "iconv() is not supported. Installing GNU libiconv and + then reinstalling this package would fix this." */ + errno = ENOSYS; + return NULL; +#endif + } +} diff --git a/lib/striconveh.h b/lib/striconveh.h new file mode 100644 index 000000000..98b4d0c5e --- /dev/null +++ b/lib/striconveh.h @@ -0,0 +1,120 @@ +/* Character set conversion with error handling. + Copyright (C) 2001-2007, 2009 Free Software Foundation, Inc. + Written by Bruno Haible and Simon Josefsson. + + This program is free software: you can redistribute 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 _STRICONVEH_H +#define _STRICONVEH_H + +#include +#if HAVE_ICONV +#include +#endif + +#include "iconveh.h" + + +#ifdef __cplusplus +extern "C" { +#endif + + +#if HAVE_ICONV + +/* Convert an entire string from one encoding to another, using iconv. + The original string is at [SRC,...,SRC+SRCLEN-1]. + CD is the conversion descriptor from FROMCODE to TOCODE, or (iconv_t)(-1) if + the system does not support a direct conversion from FROMCODE to TOCODE. + CD1 is the conversion descriptor from FROM_CODESET to UTF-8 (or + (iconv_t)(-1) if FROM_CODESET is UTF-8). + CD2 is the conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1) + if TO_CODESET is UTF-8). + If OFFSETS is not NULL, it should point to an array of SRCLEN integers; this + array is filled with offsets into the result, i.e. the character starting + at SRC[i] corresponds to the character starting at (*RESULTP)[OFFSETS[i]], + and other offsets are set to (size_t)(-1). + *RESULTP and *LENGTH should initially be a scratch buffer and its size, + or *RESULTP can initially be NULL. + May erase the contents of the memory at *RESULTP. + Return value: 0 if successful, otherwise -1 and errno set. + If successful: The resulting string is stored in *RESULTP and its length + in *LENGTHP. *RESULTP is set to a freshly allocated memory block, or is + unchanged if no dynamic memory allocation was necessary. */ +extern int + mem_cd_iconveh (const char *src, size_t srclen, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler, + size_t *offsets, + char **resultp, size_t *lengthp); + +/* Convert an entire string from one encoding to another, using iconv. + The original string is the NUL-terminated string starting at SRC. + CD is the conversion descriptor from FROMCODE to TOCODE, or (iconv_t)(-1) if + the system does not support a direct conversion from FROMCODE to TOCODE. + Both the "from" and the "to" encoding must use a single NUL byte at the end + of the string (i.e. not UCS-2, UCS-4, UTF-16, UTF-32). + CD1 is the conversion descriptor from FROM_CODESET to UTF-8 (or + (iconv_t)(-1) if FROM_CODESET is UTF-8). + CD2 is the conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1) + if TO_CODESET is UTF-8). + Allocate a malloced memory block for the result. + Return value: the freshly allocated resulting NUL-terminated string if + successful, otherwise NULL and errno set. */ +extern char * + str_cd_iconveh (const char *src, + iconv_t cd, iconv_t cd1, iconv_t cd2, + enum iconv_ilseq_handler handler); + +#endif + +/* Convert an entire string from one encoding to another, using iconv. + The original string is at [SRC,...,SRC+SRCLEN-1]. + If OFFSETS is not NULL, it should point to an array of SRCLEN integers; this + array is filled with offsets into the result, i.e. the character starting + at SRC[i] corresponds to the character starting at (*RESULTP)[OFFSETS[i]], + and other offsets are set to (size_t)(-1). + *RESULTP and *LENGTH should initially be a scratch buffer and its size, + or *RESULTP can initially be NULL. + May erase the contents of the memory at *RESULTP. + Return value: 0 if successful, otherwise -1 and errno set. + If successful: The resulting string is stored in *RESULTP and its length + in *LENGTHP. *RESULTP is set to a freshly allocated memory block, or is + unchanged if no dynamic memory allocation was necessary. */ +extern int + mem_iconveh (const char *src, size_t srclen, + const char *from_codeset, const char *to_codeset, + enum iconv_ilseq_handler handler, + size_t *offsets, + char **resultp, size_t *lengthp); + +/* Convert an entire string from one encoding to another, using iconv. + The original string is the NUL-terminated string starting at SRC. + Both the "from" and the "to" encoding must use a single NUL byte at the + end of the string (i.e. not UCS-2, UCS-4, UTF-16, UTF-32). + Allocate a malloced memory block for the result. + Return value: the freshly allocated resulting NUL-terminated string if + successful, otherwise NULL and errno set. */ +extern char * + str_iconveh (const char *src, + const char *from_codeset, const char *to_codeset, + enum iconv_ilseq_handler handler); + + +#ifdef __cplusplus +} +#endif + + +#endif /* _STRICONVEH_H */ diff --git a/lib/string.in.h b/lib/string.in.h new file mode 100644 index 000000000..ca029d7c0 --- /dev/null +++ b/lib/string.in.h @@ -0,0 +1,605 @@ +/* A GNU-like . + + Copyright (C) 1995-1996, 2001-2008 Free Software Foundation, Inc. + + This program is free software; you can redistribute 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, write to the Free Software Foundation, + Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ + +#ifndef _GL_STRING_H + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_STRING_H@ + +#ifndef _GL_STRING_H +#define _GL_STRING_H + + +#ifndef __attribute__ +/* This feature is available in gcc versions 2.5 and later. */ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5) +# define __attribute__(Spec) /* empty */ +# endif +/* The attribute __pure__ was added in gcc 2.96. */ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96) +# define __pure__ /* empty */ +# endif +#endif + + +/* The definition of GL_LINK_WARNING is copied here. */ + + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Return the first occurrence of NEEDLE in HAYSTACK. */ +#if @GNULIB_MEMMEM@ +# if @REPLACE_MEMMEM@ +# define memmem rpl_memmem +# endif +# if ! @HAVE_DECL_MEMMEM@ || @REPLACE_MEMMEM@ +extern void *memmem (void const *__haystack, size_t __haystack_len, + void const *__needle, size_t __needle_len) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef memmem +# define memmem(a,al,b,bl) \ + (GL_LINK_WARNING ("memmem is unportable and often quadratic - " \ + "use gnulib module memmem-simple for portability, " \ + "and module memmem for speed" ), \ + memmem (a, al, b, bl)) +#endif + +/* Copy N bytes of SRC to DEST, return pointer to bytes after the + last written byte. */ +#if @GNULIB_MEMPCPY@ +# if ! @HAVE_MEMPCPY@ +extern void *mempcpy (void *restrict __dest, void const *restrict __src, + size_t __n); +# endif +#elif defined GNULIB_POSIXCHECK +# undef mempcpy +# define mempcpy(a,b,n) \ + (GL_LINK_WARNING ("mempcpy is unportable - " \ + "use gnulib module mempcpy for portability"), \ + mempcpy (a, b, n)) +#endif + +/* Search backwards through a block for a byte (specified as an int). */ +#if @GNULIB_MEMRCHR@ +# if ! @HAVE_DECL_MEMRCHR@ +extern void *memrchr (void const *, int, size_t) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef memrchr +# define memrchr(a,b,c) \ + (GL_LINK_WARNING ("memrchr is unportable - " \ + "use gnulib module memrchr for portability"), \ + memrchr (a, b, c)) +#endif + +/* Find the first occurrence of C in S. More efficient than + memchr(S,C,N), at the expense of undefined behavior if C does not + occur within N bytes. */ +#if @GNULIB_RAWMEMCHR@ +# if ! @HAVE_RAWMEMCHR@ +extern void *rawmemchr (void const *__s, int __c_in) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef rawmemchr +# define rawmemchr(a,b) \ + (GL_LINK_WARNING ("rawmemchr is unportable - " \ + "use gnulib module rawmemchr for portability"), \ + rawmemchr (a, b)) +#endif + +/* Copy SRC to DST, returning the address of the terminating '\0' in DST. */ +#if @GNULIB_STPCPY@ +# if ! @HAVE_STPCPY@ +extern char *stpcpy (char *restrict __dst, char const *restrict __src); +# endif +#elif defined GNULIB_POSIXCHECK +# undef stpcpy +# define stpcpy(a,b) \ + (GL_LINK_WARNING ("stpcpy is unportable - " \ + "use gnulib module stpcpy for portability"), \ + stpcpy (a, b)) +#endif + +/* Copy no more than N bytes of SRC to DST, returning a pointer past the + last non-NUL byte written into DST. */ +#if @GNULIB_STPNCPY@ +# if ! @HAVE_STPNCPY@ +# define stpncpy gnu_stpncpy +extern char *stpncpy (char *restrict __dst, char const *restrict __src, + size_t __n); +# endif +#elif defined GNULIB_POSIXCHECK +# undef stpncpy +# define stpncpy(a,b,n) \ + (GL_LINK_WARNING ("stpncpy is unportable - " \ + "use gnulib module stpncpy for portability"), \ + stpncpy (a, b, n)) +#endif + +#if defined GNULIB_POSIXCHECK +/* strchr() does not work with multibyte strings if the locale encoding is + GB18030 and the character to be searched is a digit. */ +# undef strchr +# define strchr(s,c) \ + (GL_LINK_WARNING ("strchr cannot work correctly on character strings " \ + "in some multibyte locales - " \ + "use mbschr if you care about internationalization"), \ + strchr (s, c)) +#endif + +/* Find the first occurrence of C in S or the final NUL byte. */ +#if @GNULIB_STRCHRNUL@ +# if ! @HAVE_STRCHRNUL@ +extern char *strchrnul (char const *__s, int __c_in) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strchrnul +# define strchrnul(a,b) \ + (GL_LINK_WARNING ("strchrnul is unportable - " \ + "use gnulib module strchrnul for portability"), \ + strchrnul (a, b)) +#endif + +/* Duplicate S, returning an identical malloc'd string. */ +#if @GNULIB_STRDUP@ +# if @REPLACE_STRDUP@ +# undef strdup +# define strdup rpl_strdup +# endif +# if !(@HAVE_DECL_STRDUP@ || defined strdup) || @REPLACE_STRDUP@ +extern char *strdup (char const *__s); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strdup +# define strdup(a) \ + (GL_LINK_WARNING ("strdup is unportable - " \ + "use gnulib module strdup for portability"), \ + strdup (a)) +#endif + +/* Return a newly allocated copy of at most N bytes of STRING. */ +#if @GNULIB_STRNDUP@ +# if ! @HAVE_STRNDUP@ +# undef strndup +# define strndup rpl_strndup +# endif +# if ! @HAVE_STRNDUP@ || ! @HAVE_DECL_STRNDUP@ +extern char *strndup (char const *__string, size_t __n); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strndup +# define strndup(a,n) \ + (GL_LINK_WARNING ("strndup is unportable - " \ + "use gnulib module strndup for portability"), \ + strndup (a, n)) +#endif + +/* Find the length (number of bytes) of STRING, but scan at most + MAXLEN bytes. If no '\0' terminator is found in that many bytes, + return MAXLEN. */ +#if @GNULIB_STRNLEN@ +# if ! @HAVE_DECL_STRNLEN@ +extern size_t strnlen (char const *__string, size_t __maxlen) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strnlen +# define strnlen(a,n) \ + (GL_LINK_WARNING ("strnlen is unportable - " \ + "use gnulib module strnlen for portability"), \ + strnlen (a, n)) +#endif + +#if defined GNULIB_POSIXCHECK +/* strcspn() assumes the second argument is a list of single-byte characters. + Even in this simple case, it does not work with multibyte strings if the + locale encoding is GB18030 and one of the characters to be searched is a + digit. */ +# undef strcspn +# define strcspn(s,a) \ + (GL_LINK_WARNING ("strcspn cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbscspn if you care about internationalization"), \ + strcspn (s, a)) +#endif + +/* Find the first occurrence in S of any character in ACCEPT. */ +#if @GNULIB_STRPBRK@ +# if ! @HAVE_STRPBRK@ +extern char *strpbrk (char const *__s, char const *__accept) + __attribute__ ((__pure__)); +# endif +# if defined GNULIB_POSIXCHECK +/* strpbrk() assumes the second argument is a list of single-byte characters. + Even in this simple case, it does not work with multibyte strings if the + locale encoding is GB18030 and one of the characters to be searched is a + digit. */ +# undef strpbrk +# define strpbrk(s,a) \ + (GL_LINK_WARNING ("strpbrk cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbspbrk if you care about internationalization"), \ + strpbrk (s, a)) +# endif +#elif defined GNULIB_POSIXCHECK +# undef strpbrk +# define strpbrk(s,a) \ + (GL_LINK_WARNING ("strpbrk is unportable - " \ + "use gnulib module strpbrk for portability"), \ + strpbrk (s, a)) +#endif + +#if defined GNULIB_POSIXCHECK +/* strspn() assumes the second argument is a list of single-byte characters. + Even in this simple case, it cannot work with multibyte strings. */ +# undef strspn +# define strspn(s,a) \ + (GL_LINK_WARNING ("strspn cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbsspn if you care about internationalization"), \ + strspn (s, a)) +#endif + +#if defined GNULIB_POSIXCHECK +/* strrchr() does not work with multibyte strings if the locale encoding is + GB18030 and the character to be searched is a digit. */ +# undef strrchr +# define strrchr(s,c) \ + (GL_LINK_WARNING ("strrchr cannot work correctly on character strings " \ + "in some multibyte locales - " \ + "use mbsrchr if you care about internationalization"), \ + strrchr (s, c)) +#endif + +/* Search the next delimiter (char listed in DELIM) starting at *STRINGP. + If one is found, overwrite it with a NUL, and advance *STRINGP + to point to the next char after it. Otherwise, set *STRINGP to NULL. + If *STRINGP was already NULL, nothing happens. + Return the old value of *STRINGP. + + This is a variant of strtok() that is multithread-safe and supports + empty fields. + + Caveat: It modifies the original string. + Caveat: These functions cannot be used on constant strings. + Caveat: The identity of the delimiting character is lost. + Caveat: It doesn't work with multibyte strings unless all of the delimiter + characters are ASCII characters < 0x30. + + See also strtok_r(). */ +#if @GNULIB_STRSEP@ +# if ! @HAVE_STRSEP@ +extern char *strsep (char **restrict __stringp, char const *restrict __delim); +# endif +# if defined GNULIB_POSIXCHECK +# undef strsep +# define strsep(s,d) \ + (GL_LINK_WARNING ("strsep cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbssep if you care about internationalization"), \ + strsep (s, d)) +# endif +#elif defined GNULIB_POSIXCHECK +# undef strsep +# define strsep(s,d) \ + (GL_LINK_WARNING ("strsep is unportable - " \ + "use gnulib module strsep for portability"), \ + strsep (s, d)) +#endif + +#if @GNULIB_STRSTR@ +# if @REPLACE_STRSTR@ +# define strstr rpl_strstr +char *strstr (const char *haystack, const char *needle) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +/* strstr() does not work with multibyte strings if the locale encoding is + different from UTF-8: + POSIX says that it operates on "strings", and "string" in POSIX is defined + as a sequence of bytes, not of characters. */ +# undef strstr +# define strstr(a,b) \ + (GL_LINK_WARNING ("strstr is quadratic on many systems, and cannot " \ + "work correctly on character strings in most " \ + "multibyte locales - " \ + "use mbsstr if you care about internationalization, " \ + "or use strstr if you care about speed"), \ + strstr (a, b)) +#endif + +/* Find the first occurrence of NEEDLE in HAYSTACK, using case-insensitive + comparison. */ +#if @GNULIB_STRCASESTR@ +# if @REPLACE_STRCASESTR@ +# define strcasestr rpl_strcasestr +# endif +# if ! @HAVE_STRCASESTR@ || @REPLACE_STRCASESTR@ +extern char *strcasestr (const char *haystack, const char *needle) + __attribute__ ((__pure__)); +# endif +#elif defined GNULIB_POSIXCHECK +/* strcasestr() does not work with multibyte strings: + It is a glibc extension, and glibc implements it only for unibyte + locales. */ +# undef strcasestr +# define strcasestr(a,b) \ + (GL_LINK_WARNING ("strcasestr does work correctly on character strings " \ + "in multibyte locales - " \ + "use mbscasestr if you care about " \ + "internationalization, or use c-strcasestr if you want " \ + "a locale independent function"), \ + strcasestr (a, b)) +#endif + +/* Parse S into tokens separated by characters in DELIM. + If S is NULL, the saved pointer in SAVE_PTR is used as + the next starting point. For example: + char s[] = "-abc-=-def"; + char *sp; + x = strtok_r(s, "-", &sp); // x = "abc", sp = "=-def" + x = strtok_r(NULL, "-=", &sp); // x = "def", sp = NULL + x = strtok_r(NULL, "=", &sp); // x = NULL + // s = "abc\0-def\0" + + This is a variant of strtok() that is multithread-safe. + + For the POSIX documentation for this function, see: + http://www.opengroup.org/susv3xsh/strtok.html + + Caveat: It modifies the original string. + Caveat: These functions cannot be used on constant strings. + Caveat: The identity of the delimiting character is lost. + Caveat: It doesn't work with multibyte strings unless all of the delimiter + characters are ASCII characters < 0x30. + + See also strsep(). */ +#if @GNULIB_STRTOK_R@ +# if ! @HAVE_DECL_STRTOK_R@ +extern char *strtok_r (char *restrict s, char const *restrict delim, + char **restrict save_ptr); +# endif +# if defined GNULIB_POSIXCHECK +# undef strtok_r +# define strtok_r(s,d,p) \ + (GL_LINK_WARNING ("strtok_r cannot work correctly on character strings " \ + "in multibyte locales - " \ + "use mbstok_r if you care about internationalization"), \ + strtok_r (s, d, p)) +# endif +#elif defined GNULIB_POSIXCHECK +# undef strtok_r +# define strtok_r(s,d,p) \ + (GL_LINK_WARNING ("strtok_r is unportable - " \ + "use gnulib module strtok_r for portability"), \ + strtok_r (s, d, p)) +#endif + + +/* The following functions are not specified by POSIX. They are gnulib + extensions. */ + +#if @GNULIB_MBSLEN@ +/* Return the number of multibyte characters in the character string STRING. + This considers multibyte characters, unlike strlen, which counts bytes. */ +extern size_t mbslen (const char *string); +#endif + +#if @GNULIB_MBSNLEN@ +/* Return the number of multibyte characters in the character string starting + at STRING and ending at STRING + LEN. */ +extern size_t mbsnlen (const char *string, size_t len); +#endif + +#if @GNULIB_MBSCHR@ +/* Locate the first single-byte character C in the character string STRING, + and return a pointer to it. Return NULL if C is not found in STRING. + Unlike strchr(), this function works correctly in multibyte locales with + encodings such as GB18030. */ +# define mbschr rpl_mbschr /* avoid collision with HP-UX function */ +extern char * mbschr (const char *string, int c); +#endif + +#if @GNULIB_MBSRCHR@ +/* Locate the last single-byte character C in the character string STRING, + and return a pointer to it. Return NULL if C is not found in STRING. + Unlike strrchr(), this function works correctly in multibyte locales with + encodings such as GB18030. */ +# define mbsrchr rpl_mbsrchr /* avoid collision with HP-UX function */ +extern char * mbsrchr (const char *string, int c); +#endif + +#if @GNULIB_MBSSTR@ +/* Find the first occurrence of the character string NEEDLE in the character + string HAYSTACK. Return NULL if NEEDLE is not found in HAYSTACK. + Unlike strstr(), this function works correctly in multibyte locales with + encodings different from UTF-8. */ +extern char * mbsstr (const char *haystack, const char *needle); +#endif + +#if @GNULIB_MBSCASECMP@ +/* Compare the character strings S1 and S2, ignoring case, returning less than, + equal to or greater than zero if S1 is lexicographically less than, equal to + or greater than S2. + Note: This function may, in multibyte locales, return 0 for strings of + different lengths! + Unlike strcasecmp(), this function works correctly in multibyte locales. */ +extern int mbscasecmp (const char *s1, const char *s2); +#endif + +#if @GNULIB_MBSNCASECMP@ +/* Compare the initial segment of the character string S1 consisting of at most + N characters with the initial segment of the character string S2 consisting + of at most N characters, ignoring case, returning less than, equal to or + greater than zero if the initial segment of S1 is lexicographically less + than, equal to or greater than the initial segment of S2. + Note: This function may, in multibyte locales, return 0 for initial segments + of different lengths! + Unlike strncasecmp(), this function works correctly in multibyte locales. + But beware that N is not a byte count but a character count! */ +extern int mbsncasecmp (const char *s1, const char *s2, size_t n); +#endif + +#if @GNULIB_MBSPCASECMP@ +/* Compare the initial segment of the character string STRING consisting of + at most mbslen (PREFIX) characters with the character string PREFIX, + ignoring case, returning less than, equal to or greater than zero if this + initial segment is lexicographically less than, equal to or greater than + PREFIX. + Note: This function may, in multibyte locales, return 0 if STRING is of + smaller length than PREFIX! + Unlike strncasecmp(), this function works correctly in multibyte + locales. */ +extern char * mbspcasecmp (const char *string, const char *prefix); +#endif + +#if @GNULIB_MBSCASESTR@ +/* Find the first occurrence of the character string NEEDLE in the character + string HAYSTACK, using case-insensitive comparison. + Note: This function may, in multibyte locales, return success even if + strlen (haystack) < strlen (needle) ! + Unlike strcasestr(), this function works correctly in multibyte locales. */ +extern char * mbscasestr (const char *haystack, const char *needle); +#endif + +#if @GNULIB_MBSCSPN@ +/* Find the first occurrence in the character string STRING of any character + in the character string ACCEPT. Return the number of bytes from the + beginning of the string to this occurrence, or to the end of the string + if none exists. + Unlike strcspn(), this function works correctly in multibyte locales. */ +extern size_t mbscspn (const char *string, const char *accept); +#endif + +#if @GNULIB_MBSPBRK@ +/* Find the first occurrence in the character string STRING of any character + in the character string ACCEPT. Return the pointer to it, or NULL if none + exists. + Unlike strpbrk(), this function works correctly in multibyte locales. */ +# define mbspbrk rpl_mbspbrk /* avoid collision with HP-UX function */ +extern char * mbspbrk (const char *string, const char *accept); +#endif + +#if @GNULIB_MBSSPN@ +/* Find the first occurrence in the character string STRING of any character + not in the character string REJECT. Return the number of bytes from the + beginning of the string to this occurrence, or to the end of the string + if none exists. + Unlike strspn(), this function works correctly in multibyte locales. */ +extern size_t mbsspn (const char *string, const char *reject); +#endif + +#if @GNULIB_MBSSEP@ +/* Search the next delimiter (multibyte character listed in the character + string DELIM) starting at the character string *STRINGP. + If one is found, overwrite it with a NUL, and advance *STRINGP to point + to the next multibyte character after it. Otherwise, set *STRINGP to NULL. + If *STRINGP was already NULL, nothing happens. + Return the old value of *STRINGP. + + This is a variant of mbstok_r() that supports empty fields. + + Caveat: It modifies the original string. + Caveat: These functions cannot be used on constant strings. + Caveat: The identity of the delimiting character is lost. + + See also mbstok_r(). */ +extern char * mbssep (char **stringp, const char *delim); +#endif + +#if @GNULIB_MBSTOK_R@ +/* Parse the character string STRING into tokens separated by characters in + the character string DELIM. + If STRING is NULL, the saved pointer in SAVE_PTR is used as + the next starting point. For example: + char s[] = "-abc-=-def"; + char *sp; + x = mbstok_r(s, "-", &sp); // x = "abc", sp = "=-def" + x = mbstok_r(NULL, "-=", &sp); // x = "def", sp = NULL + x = mbstok_r(NULL, "=", &sp); // x = NULL + // s = "abc\0-def\0" + + Caveat: It modifies the original string. + Caveat: These functions cannot be used on constant strings. + Caveat: The identity of the delimiting character is lost. + + See also mbssep(). */ +extern char * mbstok_r (char *string, const char *delim, char **save_ptr); +#endif + +/* Map any int, typically from errno, into an error message. */ +#if @GNULIB_STRERROR@ +# if @REPLACE_STRERROR@ +# undef strerror +# define strerror rpl_strerror +extern char *strerror (int); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strerror +# define strerror(e) \ + (GL_LINK_WARNING ("strerror is unportable - " \ + "use gnulib module strerror to guarantee non-NULL result"), \ + strerror (e)) +#endif + +#if @GNULIB_STRSIGNAL@ +# if @REPLACE_STRSIGNAL@ +# define strsignal rpl_strsignal +# endif +# if ! @HAVE_DECL_STRSIGNAL@ || @REPLACE_STRSIGNAL@ +extern char *strsignal (int __sig); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strsignal +# define strsignal(a) \ + (GL_LINK_WARNING ("strsignal is unportable - " \ + "use gnulib module strsignal for portability"), \ + strsignal (a)) +#endif + +#if @GNULIB_STRVERSCMP@ +# if !@HAVE_STRVERSCMP@ +extern int strverscmp (const char *, const char *); +# endif +#elif defined GNULIB_POSIXCHECK +# undef strverscmp +# define strverscmp(a, b) \ + (GL_LINK_WARNING ("strverscmp is unportable - " \ + "use gnulib module strverscmp for portability"), \ + strverscmp (a, b)) +#endif + + +#ifdef __cplusplus +} +#endif + +#endif /* _GL_STRING_H */ +#endif /* _GL_STRING_H */ diff --git a/lib/unistr.h b/lib/unistr.h new file mode 100644 index 000000000..83ff13411 --- /dev/null +++ b/lib/unistr.h @@ -0,0 +1,681 @@ +/* Elementary Unicode string functions. + Copyright (C) 2001-2002, 2005-2009 Free Software Foundation, Inc. + + This program is free software: you can redistribute 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 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); + +/* 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); + +/* 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); + + +/* 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); +extern int + u16_mblen (const uint16_t *s, size_t n); +extern int + u32_mblen (const uint32_t *s, size_t n); + +/* 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. */ + +#ifdef GNULIB_UNISTR_U8_MBTOUC_UNSAFE +# 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 + +#ifdef GNULIB_UNISTR_U16_MBTOUC_UNSAFE +# 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 + +#ifdef GNULIB_UNISTR_U32_MBTOUC_UNSAFE +# 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 _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 + +#ifdef GNULIB_UNISTR_U8_MBTOUC +# 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 + +#ifdef GNULIB_UNISTR_U16_MBTOUC +# 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 + +#ifdef GNULIB_UNISTR_U32_MBTOUC +# 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 _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(). */ + +#ifdef GNULIB_UNISTR_U8_MBTOUCR +extern int + u8_mbtoucr (ucs4_t *puc, const uint8_t *s, size_t n); +#endif + +#ifdef GNULIB_UNISTR_U16_MBTOUCR +extern int + u16_mbtoucr (ucs4_t *puc, const uint16_t *s, size_t n); +#endif + +#ifdef GNULIB_UNISTR_U32_MBTOUCR +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. */ + +#ifdef GNULIB_UNISTR_U8_UCTOMB +/* 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 + +#ifdef GNULIB_UNISTR_U16_UCTOMB +/* 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 + +#ifdef GNULIB_UNISTR_U32_UCTOMB +# 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); +extern int + u16_cmp (const uint16_t *s1, const uint16_t *s2, size_t n); +extern int + u32_cmp (const uint32_t *s1, const uint32_t *s2, size_t n); + +/* 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); +extern int + u16_cmp2 (const uint16_t *s1, size_t n1, const uint16_t *s2, size_t n2); +extern int + u32_cmp2 (const uint32_t *s1, size_t n1, const uint32_t *s2, size_t n2); + +/* 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); +extern uint16_t * + u16_chr (const uint16_t *s, size_t n, ucs4_t uc); +extern uint32_t * + u32_chr (const uint32_t *s, size_t n, ucs4_t uc); + +/* 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); +extern size_t + u16_mbsnlen (const uint16_t *s, size_t n); +extern size_t + u32_mbsnlen (const uint32_t *s, size_t n); + +/* 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); +extern int + u16_strmblen (const uint16_t *s); +extern int + u32_strmblen (const uint32_t *s); + +/* 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); +extern size_t + u16_strlen (const uint16_t *s); +extern size_t + u32_strlen (const uint32_t *s); + +/* 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); +extern size_t + u16_strnlen (const uint16_t *s, size_t maxlen); +extern size_t + u32_strnlen (const uint32_t *s, size_t maxlen); + +/* 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, returning the address of + the last 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(). */ +extern int + u8_strcmp (const uint8_t *s1, const uint8_t *s2); +extern int + u16_strcmp (const uint16_t *s1, const uint16_t *s2); +extern int + u32_strcmp (const uint32_t *s1, const uint32_t *s2); + +/* 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); +extern int + u16_strncmp (const uint16_t *s1, const uint16_t *s2, size_t n); +extern int + u32_strncmp (const uint32_t *s1, const uint32_t *s2, size_t n); + +/* 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); +extern uint16_t * + u16_strchr (const uint16_t *str, ucs4_t uc); +extern uint32_t * + u32_strchr (const uint32_t *str, ucs4_t uc); + +/* Find the last occurrence of UC in STR. */ +/* Similar to strrchr(), wcsrchr(). */ +extern uint8_t * + u8_strrchr (const uint8_t *str, ucs4_t uc); +extern uint16_t * + u16_strrchr (const uint16_t *str, ucs4_t uc); +extern uint32_t * + u32_strrchr (const uint32_t *str, ucs4_t uc); + +/* 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); +extern size_t + u16_strcspn (const uint16_t *str, const uint16_t *reject); +extern size_t + u32_strcspn (const uint32_t *str, const uint32_t *reject); + +/* 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); +extern size_t + u16_strspn (const uint16_t *str, const uint16_t *accept); +extern size_t + u32_strspn (const uint32_t *str, const uint32_t *accept); + +/* 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); +extern uint16_t * + u16_strpbrk (const uint16_t *str, const uint16_t *accept); +extern uint32_t * + u32_strpbrk (const uint32_t *str, const uint32_t *accept); + +/* 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); +extern uint16_t * + u16_strstr (const uint16_t *haystack, const uint16_t *needle); +extern uint32_t * + u32_strstr (const uint32_t *haystack, const uint32_t *needle); + +/* Test whether STR starts with PREFIX. */ +extern bool + u8_startswith (const uint8_t *str, const uint8_t *prefix); +extern bool + u16_startswith (const uint16_t *str, const uint16_t *prefix); +extern bool + u32_startswith (const uint32_t *str, const uint32_t *prefix); + +/* Test whether STR ends with SUFFIX. */ +extern bool + u8_endswith (const uint8_t *str, const uint8_t *suffix); +extern bool + u16_endswith (const uint16_t *str, const uint16_t *suffix); +extern bool + u32_endswith (const uint32_t *str, const uint32_t *suffix); + +/* 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 new file mode 100644 index 000000000..53d02bf0d --- /dev/null +++ b/lib/unistr/u8-mbtouc-aux.c @@ -0,0 +1,158 @@ +/* Conversion UTF-8 to UCS-4. + Copyright (C) 2001-2002, 2006-2007, 2009 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 n; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (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 */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf8) + { + if (n >= 4) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (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 */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 5) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (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 */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xfe) + { + if (n >= 6) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (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 */ + } + 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 new file mode 100644 index 000000000..43e4a360f --- /dev/null +++ b/lib/unistr/u8-mbtouc-unsafe-aux.c @@ -0,0 +1,168 @@ +/* Conversion UTF-8 to UCS-4. + Copyright (C) 2001-2002, 2006-2007, 2009 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; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (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; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf8) + { + if (n >= 4) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (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; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 5) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (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; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xfe) + { + if (n >= 6) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (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; + } + /* 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.c b/lib/unistr/u8-mbtouc-unsafe.c new file mode 100644 index 000000000..466156967 --- /dev/null +++ b/lib/unistr/u8-mbtouc-unsafe.c @@ -0,0 +1,179 @@ +/* Look at first character in UTF-8 string. + Copyright (C) 1999-2002, 2006-2007, 2009 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; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (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; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf8) + { + if (n >= 4) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (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; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 5) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (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; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xfe) + { + if (n >= 6) + { +#if CONFIG_UNICODE_SAFETY + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (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; + } + /* 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.c b/lib/unistr/u8-mbtouc.c new file mode 100644 index 000000000..ff624f17d --- /dev/null +++ b/lib/unistr/u8-mbtouc.c @@ -0,0 +1,168 @@ +/* Look at first character in UTF-8 string. + Copyright (C) 1999-2002, 2006-2007, 2009 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 n; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (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 */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xf8) + { + if (n >= 4) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 + && (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 */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } +#if 0 + else if (c < 0xfc) + { + if (n >= 5) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (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 */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return n; + } + } + else if (c < 0xfe) + { + if (n >= 6) + { + if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40 + && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40 + && (s[5] ^ 0x80) < 0x40 + && (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 */ + } + 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 new file mode 100644 index 000000000..dd8335247 --- /dev/null +++ b/lib/unistr/u8-mbtoucr.c @@ -0,0 +1,285 @@ +/* Look at first character in UTF-8 string, returning an error code. + Copyright (C) 1999-2002, 2006-2007 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 new file mode 100644 index 000000000..245d22ff0 --- /dev/null +++ b/lib/unistr/u8-prev.c @@ -0,0 +1,93 @@ +/* Iterate over previous character in UTF-8 string. + Copyright (C) 2002, 2006-2007 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 utf8-ucs4.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 new file mode 100644 index 000000000..c42fa5015 --- /dev/null +++ b/lib/unistr/u8-uctomb-aux.c @@ -0,0 +1,69 @@ +/* Conversion UCS-4 to UTF-8. + Copyright (C) 2002, 2006-2007 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 new file mode 100644 index 000000000..33921669e --- /dev/null +++ b/lib/unistr/u8-uctomb.c @@ -0,0 +1,88 @@ +/* Store a character in UTF-8 string. + Copyright (C) 2002, 2005-2006, 2009 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.h b/lib/unitypes.h new file mode 100644 index 000000000..fe8d87735 --- /dev/null +++ b/lib/unitypes.h @@ -0,0 +1,26 @@ +/* Elementary types for the GNU UniString library. + Copyright (C) 2002, 2005-2006 Free Software Foundation, Inc. + + This program is free software: you can redistribute 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; + +#endif /* _UNITYPES_H */ diff --git a/libguile.h b/libguile.h index 40122dfa2..6a6d232f9 100644 --- a/libguile.h +++ b/libguile.h @@ -1,7 +1,7 @@ #ifndef SCM_LIBGUILE_H #define SCM_LIBGUILE_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -32,6 +32,7 @@ extern "C" { #include "libguile/arbiters.h" #include "libguile/async.h" #include "libguile/boolean.h" +#include "libguile/bytevectors.h" #include "libguile/chars.h" #include "libguile/continuations.h" #include "libguile/dynl.h" @@ -75,6 +76,7 @@ extern "C" { #include "libguile/procprop.h" #include "libguile/properties.h" #include "libguile/procs.h" +#include "libguile/r6rs-ports.h" #include "libguile/ramap.h" #include "libguile/random.h" #include "libguile/read.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 369b24951..fcf197a54 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -32,10 +32,10 @@ DEFAULT_INCLUDES = ## Check for headers in $(srcdir)/.., so that #include ## will find MUMBLE.h in this dir when we're ## building. Also look for Gnulib headers in `lib'. -AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \ +AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \ -I$(top_srcdir)/lib -I$(top_builddir)/lib -AM_CFLAGS = $(GCC_CFLAGS) +AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY) ## The Gnulib Libtool archive. gnulib_library = $(top_builddir)/lib/libgnu.la @@ -106,7 +106,8 @@ guile_LDFLAGS = $(GUILE_CFLAGS) libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS) libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ - chars.c continuations.c convert.c debug.c deprecation.c \ + bytevectors.c chars.c continuations.c \ + convert.c debug.c deprecation.c \ deprecated.c discouraged.c dynwind.c eq.c error.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \ futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \ @@ -115,7 +116,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ guardians.c hash.c hashtab.c hooks.c init.c inline.c \ ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \ modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ - print.c procprop.c procs.c properties.c random.c rdelim.c read.c \ + print.c procprop.c procs.c properties.c \ + r6rs-ports.c random.c rdelim.c read.c \ root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \ stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \ strorder.c strports.c struct.c symbols.c threads.c null-threads.c \ @@ -134,7 +136,8 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \ -module -L$(builddir) -lguile \ -version-info @LIBGUILE_I18N_INTERFACE@ -DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ +DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x \ + bytevectors.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ dynl.x dynwind.x eq.x error.x eval.x evalext.x \ extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \ @@ -143,7 +146,8 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \ list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \ - properties.x random.x rdelim.x read.x root.x rw.x scmsigs.x \ + properties.x r6rs-ports.x random.x rdelim.x \ + read.x root.x rw.x scmsigs.x \ script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x \ stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x \ strports.x struct.x symbols.x threads.x throw.x values.x \ @@ -155,7 +159,8 @@ DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ - boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \ + boolean.doc bytevectors.doc chars.doc \ + continuations.doc debug.doc deprecation.doc \ deprecated.doc discouraged.doc dynl.doc dynwind.doc \ eq.doc error.doc eval.doc evalext.doc \ extensions.doc feature.doc fluids.doc fports.doc futures.doc \ @@ -165,7 +170,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \ list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \ objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \ - procprop.doc procs.doc properties.doc random.doc rdelim.doc \ + procprop.doc procs.doc properties.doc r6rs-ports.doc \ + random.doc rdelim.doc \ read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc \ smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc \ strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc \ @@ -204,7 +210,7 @@ install-exec-hook: ## working. noinst_HEADERS = convert.i.c \ conv-integer.i.c conv-uinteger.i.c \ - eval.i.c \ + eval.i.c ieee-754.h \ srfi-4.i.c \ quicksort.i.c \ win32-uname.h win32-dirent.h win32-socket.h \ @@ -223,7 +229,8 @@ pkginclude_HEADERS = # These are headers visible as . modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ - boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \ + boolean.h bytevectors.h chars.h continuations.h convert.h \ + debug.h debug-malloc.h \ deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \ eq.h error.h eval.h evalext.h extensions.h \ feature.h filesys.h fluids.h fports.h futures.h gc.h \ @@ -232,7 +239,8 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \ keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \ - posix.h regex-posix.h print.h procprop.h procs.h properties.h \ + posix.h r6rs-ports.h regex-posix.h print.h \ + procprop.h procs.h properties.h \ random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \ script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \ stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \ diff --git a/libguile/__scm.h b/libguile/__scm.h index 3672b1c09..07d7b4d3d 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -98,13 +98,10 @@ #define SCM_UNLIKELY(_expr) SCM_EXPECT ((_expr), 0) /* The SCM_INTERNAL macro makes it possible to explicitly declare a function - * as having "internal" linkage. */ -#if (defined __GNUC__) && \ - ((__GNUC__ >= 4) || (__GNUC__ == 3 && __GNUC_MINOR__ == 3)) -# define SCM_INTERNAL extern __attribute__ ((__visibility__ ("internal"))) -#else -# define SCM_INTERNAL extern -#endif + * as having "internal" linkage. However our current tack on this problem is + * to use GCC 4's -fvisibility=hidden, making functions internal by default, + * and then SCM_API marks them for export. */ +#define SCM_INTERNAL extern @@ -154,13 +151,14 @@ /* SCM_API is a macro prepended to all function and data definitions - which should be exported or imported in the resulting dynamic link - library (DLL) in the Win32 port. */ + which should be exported from libguile. */ -#if defined (SCM_IMPORT) -# define SCM_API __declspec (dllimport) extern -#elif defined (SCM_EXPORT) || defined (DLL_EXPORT) -# define SCM_API __declspec (dllexport) extern +#if BUILDING_LIBGUILE && HAVE_VISIBILITY +# define SCM_API extern __attribute__((__visibility__("default"))) +#elif BUILDING_LIBGUILE && defined _MSC_VER +# define SCM_API __declspec(dllexport) extern +#elif defined _MSC_VER +# define SCM_API __declspec(dllimport) extern #else # define SCM_API extern #endif diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c new file mode 100644 index 000000000..4c3a353a1 --- /dev/null +++ b/libguile/bytevectors.c @@ -0,0 +1,1978 @@ +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 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/bytevectors.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/ieee-754.h" + +#include +#include +#include + +#ifdef HAVE_LIMITS_H +# include +#else +/* Assuming 32-bit longs. */ +# define ULONG_MAX 4294967295UL +#endif + +#include + + + +/* Utilities. */ + +/* Convenience macros. These are used by the various templates (macros) that + are parameterized by integer signedness. */ +#define INT8_T_signed scm_t_int8 +#define INT8_T_unsigned scm_t_uint8 +#define INT16_T_signed scm_t_int16 +#define INT16_T_unsigned scm_t_uint16 +#define INT32_T_signed scm_t_int32 +#define INT32_T_unsigned scm_t_uint32 +#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L)) +#define is_unsigned_int8(_x) ((_x) <= 255UL) +#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L)) +#define is_unsigned_int16(_x) ((_x) <= 65535UL) +#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L)) +#define is_unsigned_int32(_x) ((_x) <= 4294967295UL) +#define SIGNEDNESS_signed 1 +#define SIGNEDNESS_unsigned 0 + +#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign +#define INT_SWAP(_size) bswap_ ## _size +#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size +#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign + + +#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \ + unsigned c_len, c_index; \ + _sign char *c_bv; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + c_index = scm_to_uint (index); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \ + scm_out_of_range (FUNC_NAME, index); + +/* Template for fixed-size integer access (only 8, 16 or 32-bit). */ +#define INTEGER_REF(_len, _sign) \ + SCM result; \ + \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + { \ + INT_TYPE (_len, _sign) c_result; \ + \ + memcpy (&c_result, &c_bv[c_index], (_len) / 8); \ + if (!scm_is_eq (endianness, native_endianness)) \ + c_result = INT_SWAP (_len) (c_result); \ + \ + result = SCM_I_MAKINUM (c_result); \ + } \ + \ + return result; + +/* Template for fixed-size integer access using the native endianness. */ +#define INTEGER_NATIVE_REF(_len, _sign) \ + SCM result; \ + \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + { \ + INT_TYPE (_len, _sign) c_result; \ + \ + memcpy (&c_result, &c_bv[c_index], (_len) / 8); \ + result = SCM_I_MAKINUM (c_result); \ + } \ + \ + return result; + +/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */ +#define INTEGER_SET(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + { \ + _sign long c_value; \ + INT_TYPE (_len, _sign) c_value_short; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + scm_wrong_type_arg (FUNC_NAME, 3, value); \ + \ + c_value = SCM_I_INUM (value); \ + if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + c_value_short = (INT_TYPE (_len, _sign)) c_value; \ + if (!scm_is_eq (endianness, native_endianness)) \ + c_value_short = INT_SWAP (_len) (c_value_short); \ + \ + memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \ + } \ + \ + return SCM_UNSPECIFIED; + +/* Template for fixed-size integer modification using the native + endianness. */ +#define INTEGER_NATIVE_SET(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + { \ + _sign long c_value; \ + INT_TYPE (_len, _sign) c_value_short; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + scm_wrong_type_arg (FUNC_NAME, 3, value); \ + \ + c_value = SCM_I_INUM (value); \ + if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + c_value_short = (INT_TYPE (_len, _sign)) c_value; \ + \ + memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \ + } \ + \ + return SCM_UNSPECIFIED; + + + +/* Bytevector type. */ + +SCM_GLOBAL_SMOB (scm_tc16_bytevector, "r6rs-bytevector", 0); + +#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \ + SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len)) +#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \ + SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf)) + +/* The empty bytevector. */ +SCM scm_null_bytevector = SCM_UNSPECIFIED; + + +static inline SCM +make_bytevector_from_buffer (unsigned len, signed char *contents) +{ + /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */ + SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents); +} + +static inline SCM +make_bytevector (unsigned len) +{ + SCM bv; + + if (SCM_UNLIKELY (len == 0)) + bv = scm_null_bytevector; + else + { + signed char *contents = NULL; + + if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)) + contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR); + + bv = make_bytevector_from_buffer (len, contents); + } + + return bv; +} + +/* Return a new bytevector of size LEN octets. */ +SCM +scm_c_make_bytevector (unsigned len) +{ + return (make_bytevector (len)); +} + +/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to + by CONTENTS must have been allocated using `scm_gc_malloc ()'. */ +SCM +scm_c_take_bytevector (signed char *contents, unsigned len) +{ + SCM bv; + + if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))) + { + /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */ + signed char *c_bv; + + bv = make_bytevector (len); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + memcpy (c_bv, contents, len); + scm_gc_free (contents, len, SCM_GC_BYTEVECTOR); + } + else + bv = make_bytevector_from_buffer (len, contents); + + return bv; +} + +/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current + size) and return BV. */ +SCM +scm_i_shrink_bytevector (SCM bv, unsigned c_new_len) +{ + if (!SCM_BYTEVECTOR_INLINE_P (bv)) + { + unsigned c_len; + signed char *c_bv, *c_new_bv; + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len); + + if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len)) + { + /* Copy to the in-line buffer and free the current buffer. */ + c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv); + memcpy (c_new_bv, c_bv, c_new_len); + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + /* Resize the existing buffer. */ + c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len, + SCM_GC_BYTEVECTOR); + SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv); + } + } + + return bv; +} + +SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector, + bv, port, pstate) +{ + unsigned c_len, i; + unsigned char *c_bv; + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + scm_puts ("#vu8(", port); + for (i = 0; i < c_len; i++) + { + if (i > 0) + scm_putc (' ', port); + + scm_uintprint (c_bv[i], 10, port); + } + + scm_putc (')', port); + + /* Make GCC think we use it. */ + scm_remember_upto_here ((SCM) pstate); + + return 1; +} + +SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv) +{ + + if (!SCM_BYTEVECTOR_INLINE_P (bv)) + { + unsigned c_len; + signed char *c_bv; + + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + + return 0; +} + + + +/* General operations. */ + +SCM_SYMBOL (scm_sym_big, "big"); +SCM_SYMBOL (scm_sym_little, "little"); + +SCM scm_endianness_big, scm_endianness_little; + +/* Host endianness (a symbol). */ +static SCM native_endianness = SCM_UNSPECIFIED; + +/* Byte-swapping. */ +#ifndef bswap_24 +# define bswap_24(_x) \ + ((((_x) & 0xff0000) >> 16) | \ + (((_x) & 0x00ff00)) | \ + (((_x) & 0x0000ff) << 16)) +#endif + + +SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0, + (void), + "Return a symbol denoting the machine's native endianness.") +#define FUNC_NAME s_scm_native_endianness +{ + return native_endianness; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0, + (SCM obj), + "Return true if @var{obj} is a bytevector.") +#define FUNC_NAME s_scm_bytevector_p +{ + return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector, + obj))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0, + (SCM len, SCM fill), + "Return a newly allocated bytevector of @var{len} bytes, " + "optionally filled with @var{fill}.") +#define FUNC_NAME s_scm_make_bytevector +{ + SCM bv; + unsigned c_len; + signed char c_fill = '\0'; + + SCM_VALIDATE_UINT_COPY (1, len, c_len); + if (fill != SCM_UNDEFINED) + { + int value; + + value = scm_to_int (fill); + if (SCM_UNLIKELY ((value < -128) || (value > 255))) + scm_out_of_range (FUNC_NAME, fill); + c_fill = (signed char) value; + } + + bv = make_bytevector (c_len); + if (fill != SCM_UNDEFINED) + { + unsigned i; + signed char *contents; + + contents = SCM_BYTEVECTOR_CONTENTS (bv); + for (i = 0; i < c_len; i++) + contents[i] = c_fill; + } + + return bv; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0, + (SCM bv), + "Return the length (in bytes) of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_length +{ + SCM_VALIDATE_BYTEVECTOR (1, bv); + + return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0, + (SCM bv1, SCM bv2), + "Return is @var{bv1} equals to @var{bv2}---i.e., if they " + "have the same length and contents.") +#define FUNC_NAME s_scm_bytevector_eq_p +{ + SCM result = SCM_BOOL_F; + unsigned c_len1, c_len2; + + SCM_VALIDATE_BYTEVECTOR (1, bv1); + SCM_VALIDATE_BYTEVECTOR (2, bv2); + + c_len1 = SCM_BYTEVECTOR_LENGTH (bv1); + c_len2 = SCM_BYTEVECTOR_LENGTH (bv2); + + if (c_len1 == c_len2) + { + signed char *c_bv1, *c_bv2; + + c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1); + c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2); + + result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1)); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0, + (SCM bv, SCM fill), + "Fill bytevector @var{bv} with @var{fill}, a byte.") +#define FUNC_NAME s_scm_bytevector_fill_x +{ + unsigned c_len, i; + signed char *c_bv, c_fill; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + c_fill = scm_to_int8 (fill); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + for (i = 0; i < c_len; i++) + c_bv[i] = c_fill; + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0, + (SCM source, SCM source_start, SCM target, SCM target_start, + SCM 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}.") +#define FUNC_NAME s_scm_bytevector_copy_x +{ + unsigned c_len, c_source_len, c_target_len; + unsigned c_source_start, c_target_start; + signed char *c_source, *c_target; + + SCM_VALIDATE_BYTEVECTOR (1, source); + SCM_VALIDATE_BYTEVECTOR (3, target); + + c_len = scm_to_uint (len); + c_source_start = scm_to_uint (source_start); + c_target_start = scm_to_uint (target_start); + + c_source = SCM_BYTEVECTOR_CONTENTS (source); + c_target = SCM_BYTEVECTOR_CONTENTS (target); + c_source_len = SCM_BYTEVECTOR_LENGTH (source); + c_target_len = SCM_BYTEVECTOR_LENGTH (target); + + if (SCM_UNLIKELY (c_source_start + c_len > c_source_len)) + scm_out_of_range (FUNC_NAME, source_start); + if (SCM_UNLIKELY (c_target_start + c_len > c_target_len)) + scm_out_of_range (FUNC_NAME, target_start); + + memcpy (c_target + c_target_start, + c_source + c_source_start, + c_len); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0, + (SCM bv), + "Return a newly allocated copy of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_copy +{ + SCM copy; + unsigned c_len; + signed char *c_bv, *c_copy; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + copy = make_bytevector (c_len); + c_copy = SCM_BYTEVECTOR_CONTENTS (copy); + memcpy (c_copy, c_bv, c_len); + + return copy; +} +#undef FUNC_NAME + + +/* Operations on bytes and octets. */ + +SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0, + (SCM bv, SCM index), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_ref +{ + INTEGER_NATIVE_REF (8, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0, + (SCM bv, SCM index), + "Return the byte located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_s8_ref +{ + INTEGER_NATIVE_REF (8, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_set_x +{ + INTEGER_NATIVE_SET (8, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_set_x +{ + INTEGER_NATIVE_SET (8, signed); +} +#undef FUNC_NAME + +#undef OCTET_ACCESSOR_PROLOGUE + + +SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0, + (SCM bv), + "Return a newly allocated list of octets containing the " + "contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_u8_list +{ + SCM lst, pair; + unsigned c_len, i; + unsigned char *c_bv; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED); + for (i = 0, pair = lst; + i < c_len; + i++, pair = SCM_CDR (pair)) + { + SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i])); + } + + return lst; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0, + (SCM lst), + "Turn @var{lst}, a list of octets, into a bytevector.") +#define FUNC_NAME s_scm_u8_list_to_bytevector +{ + SCM bv, item; + long c_len, i; + unsigned char *c_bv; + + SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); + + bv = make_bytevector (c_len); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + for (i = 0; i < c_len; lst = SCM_CDR (lst), i++) + { + item = SCM_CAR (lst); + + if (SCM_LIKELY (SCM_I_INUMP (item))) + { + long c_item; + + c_item = SCM_I_INUM (item); + if (SCM_LIKELY ((c_item >= 0) && (c_item < 256))) + c_bv[i] = (unsigned char) c_item; + else + goto type_error; + } + else + goto type_error; + } + + return bv; + + type_error: + scm_wrong_type_arg (FUNC_NAME, 1, item); + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +/* Compute the two's complement of VALUE (a positive integer) on SIZE octets + using (2^(SIZE * 8) - VALUE). */ +static inline void +twos_complement (mpz_t value, size_t size) +{ + unsigned long bit_count; + + /* We expect BIT_COUNT to fit in a unsigned long thanks to the range + checking on SIZE performed earlier. */ + bit_count = (unsigned long) size << 3UL; + + if (SCM_LIKELY (bit_count < sizeof (unsigned long))) + mpz_ui_sub (value, 1UL << bit_count, value); + else + { + mpz_t max; + + mpz_init (max); + mpz_ui_pow_ui (max, 2, bit_count); + mpz_sub (value, max, value); + mpz_clear (max); + } +} + +static inline SCM +bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p, + SCM endianness) +{ + SCM result; + mpz_t c_mpz; + int c_endianness, negative_p = 0; + + if (signed_p) + { + if (scm_is_eq (endianness, scm_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; + + mpz_init (c_mpz); + mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */, + c_size /* word is C_SIZE-byte long */, + c_endianness, + 0 /* nails */, c_bv); + + if (signed_p && negative_p) + { + twos_complement (c_mpz, c_size); + mpz_neg (c_mpz, c_mpz); + } + + result = scm_from_mpz (c_mpz); + mpz_clear (c_mpz); /* FIXME: Needed? */ + + return result; +} + +static inline int +bytevector_large_set (char *c_bv, size_t c_size, int signed_p, + SCM value, SCM endianness) +{ + mpz_t c_mpz; + int c_endianness, c_sign, err = 0; + + c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1; + + mpz_init (c_mpz); + scm_to_mpz (value, c_mpz); + + c_sign = mpz_sgn (c_mpz); + if (c_sign < 0) + { + if (SCM_LIKELY (signed_p)) + { + mpz_neg (c_mpz, c_mpz); + twos_complement (c_mpz, c_size); + } + else + { + err = -1; + goto finish; + } + } + + if (c_sign == 0) + /* Zero. */ + memset (c_bv, 0, c_size); + else + { + size_t word_count, value_size; + + value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size); + if (SCM_UNLIKELY (value_size > c_size)) + { + err = -2; + goto finish; + } + + + mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */, + c_size, c_endianness, + 0 /* nails */, c_mpz); + if (SCM_UNLIKELY (word_count != 1)) + /* Shouldn't happen since we already checked with VALUE_SIZE. */ + abort (); + } + + finish: + mpz_clear (c_mpz); + + return err; +} + +#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \ + unsigned long c_len, c_index, c_size; \ + char *c_bv; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + c_index = scm_to_ulong (index); \ + c_size = scm_to_ulong (size); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + /* C_SIZE must have its 3 higher bits set to zero so that \ + multiplying it by 8 yields a number that fits in an \ + unsigned long. */ \ + if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \ + scm_out_of_range (FUNC_NAME, size); \ + if (SCM_UNLIKELY (c_index + c_size > c_len)) \ + scm_out_of_range (FUNC_NAME, index); + + +/* Template of an integer reference function. */ +#define GENERIC_INTEGER_REF(_sign) \ + SCM result; \ + \ + if (c_size < 3) \ + { \ + int swap; \ + _sign int value; \ + \ + swap = !scm_is_eq (endianness, native_endianness); \ + switch (c_size) \ + { \ + case 1: \ + { \ + _sign char c_value8; \ + memcpy (&c_value8, c_bv, 1); \ + value = c_value8; \ + } \ + break; \ + case 2: \ + { \ + INT_TYPE (16, _sign) c_value16; \ + memcpy (&c_value16, c_bv, 2); \ + if (swap) \ + value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \ + else \ + value = c_value16; \ + } \ + break; \ + default: \ + abort (); \ + } \ + \ + result = SCM_I_MAKINUM ((_sign int) value); \ + } \ + else \ + result = bytevector_large_ref ((char *) c_bv, \ + c_size, SIGNEDNESS (_sign), \ + endianness); \ + \ + return result; + +static inline SCM +bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness) +{ + GENERIC_INTEGER_REF (signed); +} + +static inline SCM +bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness) +{ + GENERIC_INTEGER_REF (unsigned); +} + + +/* Template of an integer assignment function. */ +#define GENERIC_INTEGER_SET(_sign) \ + if (c_size < 3) \ + { \ + _sign int c_value; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + goto range_error; \ + \ + c_value = SCM_I_INUM (value); \ + switch (c_size) \ + { \ + case 1: \ + if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \ + { \ + _sign char c_value8; \ + c_value8 = (_sign char) c_value; \ + memcpy (c_bv, &c_value8, 1); \ + } \ + else \ + goto range_error; \ + break; \ + \ + case 2: \ + if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \ + { \ + int swap; \ + INT_TYPE (16, _sign) c_value16; \ + \ + swap = !scm_is_eq (endianness, native_endianness); \ + \ + if (swap) \ + c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \ + else \ + c_value16 = c_value; \ + \ + memcpy (c_bv, &c_value16, 2); \ + } \ + else \ + goto range_error; \ + break; \ + \ + default: \ + abort (); \ + } \ + } \ + else \ + { \ + int err; \ + \ + err = bytevector_large_set (c_bv, c_size, \ + SIGNEDNESS (_sign), \ + value, endianness); \ + if (err) \ + goto range_error; \ + } \ + \ + return; \ + \ + range_error: \ + scm_out_of_range (FUNC_NAME, value); \ + return; + +static inline void +bytevector_signed_set (char *c_bv, size_t c_size, + SCM value, SCM endianness, + const char *func_name) +#define FUNC_NAME func_name +{ + GENERIC_INTEGER_SET (signed); +} +#undef FUNC_NAME + +static inline void +bytevector_unsigned_set (char *c_bv, size_t c_size, + SCM value, SCM endianness, + const char *func_name) +#define FUNC_NAME func_name +{ + GENERIC_INTEGER_SET (unsigned); +} +#undef FUNC_NAME + +#undef GENERIC_INTEGER_SET +#undef GENERIC_INTEGER_REF + + +SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0, + (SCM bv, SCM index, SCM endianness, SCM size), + "Return the @var{size}-octet long unsigned integer at index " + "@var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_uint_ref +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); + + return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0, + (SCM bv, SCM index, SCM endianness, SCM size), + "Return the @var{size}-octet long unsigned integer at index " + "@var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_sint_ref +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); + + return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness, SCM size), + "Set the @var{size}-octet long unsigned integer at @var{index} " + "to @var{value}.") +#define FUNC_NAME s_scm_bytevector_uint_set_x +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); + + bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness, + FUNC_NAME); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness, SCM size), + "Set the @var{size}-octet long signed integer at @var{index} " + "to @var{value}.") +#define FUNC_NAME s_scm_bytevector_sint_set_x +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); + + bytevector_signed_set (&c_bv[c_index], c_size, value, endianness, + FUNC_NAME); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* Operations on integers of arbitrary size. */ + +#define INTEGERS_TO_LIST(_sign) \ + SCM lst, pair; \ + size_t i, c_len, c_size; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + c_size = scm_to_uint (size); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + if (SCM_UNLIKELY (c_len == 0)) \ + lst = SCM_EOL; \ + else if (SCM_UNLIKELY (c_len < c_size)) \ + scm_out_of_range (FUNC_NAME, size); \ + else \ + { \ + const char *c_bv; \ + \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + lst = scm_make_list (scm_from_uint (c_len / c_size), \ + SCM_UNSPECIFIED); \ + for (i = 0, pair = lst; \ + i <= c_len - c_size; \ + i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \ + { \ + SCM_SETCAR (pair, \ + bytevector_ ## _sign ## _ref (c_bv, c_size, \ + endianness)); \ + } \ + } \ + \ + return lst; + +SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list", + 3, 0, 0, + (SCM bv, SCM endianness, SCM size), + "Return a list of signed integers of @var{size} octets " + "representing the contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_sint_list +{ + INTEGERS_TO_LIST (signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list", + 3, 0, 0, + (SCM bv, SCM endianness, SCM size), + "Return a list of unsigned integers of @var{size} octets " + "representing the contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_uint_list +{ + INTEGERS_TO_LIST (unsigned); +} +#undef FUNC_NAME + +#undef INTEGER_TO_LIST + + +#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \ + SCM bv; \ + long c_len; \ + size_t c_size; \ + char *c_bv, *c_bv_ptr; \ + \ + SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + c_size = scm_to_uint (size); \ + \ + if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \ + scm_out_of_range (FUNC_NAME, size); \ + \ + bv = make_bytevector (c_len * c_size); \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + for (c_bv_ptr = c_bv; \ + !scm_is_null (lst); \ + lst = SCM_CDR (lst), c_bv_ptr += c_size) \ + { \ + bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \ + SCM_CAR (lst), endianness, \ + FUNC_NAME); \ + } \ + \ + return bv; + + +SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector", + 3, 0, 0, + (SCM lst, SCM endianness, SCM size), + "Return a bytevector containing the unsigned integers " + "listed in @var{lst} and encoded on @var{size} octets " + "according to @var{endianness}.") +#define FUNC_NAME s_scm_uint_list_to_bytevector +{ + INTEGER_LIST_TO_BYTEVECTOR (unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector", + 3, 0, 0, + (SCM lst, SCM endianness, SCM size), + "Return a bytevector containing the signed integers " + "listed in @var{lst} and encoded on @var{size} octets " + "according to @var{endianness}.") +#define FUNC_NAME s_scm_sint_list_to_bytevector +{ + INTEGER_LIST_TO_BYTEVECTOR (signed); +} +#undef FUNC_NAME + +#undef INTEGER_LIST_TO_BYTEVECTOR + + + +/* Operations on 16-bit integers. */ + +SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u16_ref +{ + INTEGER_REF (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 16-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s16_ref +{ + INTEGER_REF (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u16_native_ref +{ + INTEGER_NATIVE_REF (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s16_native_ref +{ + INTEGER_NATIVE_REF (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u16_set_x +{ + INTEGER_SET (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s16_set_x +{ + INTEGER_SET (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u16_native_set_x +{ + INTEGER_NATIVE_SET (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s16_native_set_x +{ + INTEGER_NATIVE_SET (16, signed); +} +#undef FUNC_NAME + + + +/* Operations on 32-bit integers. */ + +/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold + arbitrary 32-bit integers. Thus we fall back to using the + `large_{ref,set}' variants on 32-bit machines. */ + +#define LARGE_INTEGER_REF(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), endianness)); + +#define LARGE_INTEGER_SET(_len, _sign) \ + int err; \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (4, endianness); \ + \ + err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), value, endianness); \ + if (SCM_UNLIKELY (err)) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + 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, \ + SIGNEDNESS (_sign), native_endianness)); + +#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \ + int err; \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), value, \ + native_endianness); \ + if (SCM_UNLIKELY (err)) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + return SCM_UNSPECIFIED; + + +SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u32_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_REF (32, unsigned); +#else + LARGE_INTEGER_REF (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 32-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s32_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_REF (32, signed); +#else + LARGE_INTEGER_REF (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u32_native_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_REF (32, unsigned); +#else + LARGE_INTEGER_NATIVE_REF (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s32_native_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_REF (32, signed); +#else + LARGE_INTEGER_NATIVE_REF (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u32_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_SET (32, unsigned); +#else + LARGE_INTEGER_SET (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s32_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_SET (32, signed); +#else + LARGE_INTEGER_SET (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u32_native_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_SET (32, unsigned); +#else + LARGE_INTEGER_NATIVE_SET (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s32_native_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_SET (32, signed); +#else + LARGE_INTEGER_NATIVE_SET (32, signed); +#endif +} +#undef FUNC_NAME + + + +/* Operations on 64-bit integers. */ + +/* For 64-bit integers, we use only the `large_{ref,set}' variant. */ + +SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u64_ref +{ + LARGE_INTEGER_REF (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 64-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s64_ref +{ + LARGE_INTEGER_REF (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u64_native_ref +{ + LARGE_INTEGER_NATIVE_REF (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s64_native_ref +{ + LARGE_INTEGER_NATIVE_REF (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u64_set_x +{ + LARGE_INTEGER_SET (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s64_set_x +{ + LARGE_INTEGER_SET (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u64_native_set_x +{ + LARGE_INTEGER_NATIVE_SET (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s64_native_set_x +{ + LARGE_INTEGER_NATIVE_SET (64, signed); +} +#undef FUNC_NAME + + + +/* Operations on IEEE-754 numbers. */ + +/* There are two possible word endians, visible in glibc's . + However, in R6RS, when the endianness is `little', little endian is + assumed for both the byte order and the word order. This is clear from + Section 2.1 of R6RS-lib (in response to + http://www.r6rs.org/formal-comments/comment-187.txt). */ + + +/* Convert to/from a floating-point number with different endianness. This + method is probably not the most efficient but it should be portable. */ + +static inline void +float_to_foreign_endianness (union scm_ieee754_float *target, + float source) +{ + union scm_ieee754_float src; + + src.f = source; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + target->little_endian.negative = src.big_endian.negative; + target->little_endian.exponent = src.big_endian.exponent; + target->little_endian.mantissa = src.big_endian.mantissa; +#else + target->big_endian.negative = src.little_endian.negative; + target->big_endian.exponent = src.little_endian.exponent; + target->big_endian.mantissa = src.little_endian.mantissa; +#endif +} + +static inline float +float_from_foreign_endianness (const union scm_ieee754_float *source) +{ + union scm_ieee754_float result; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + result.big_endian.negative = source->little_endian.negative; + result.big_endian.exponent = source->little_endian.exponent; + result.big_endian.mantissa = source->little_endian.mantissa; +#else + result.little_endian.negative = source->big_endian.negative; + result.little_endian.exponent = source->big_endian.exponent; + result.little_endian.mantissa = source->big_endian.mantissa; +#endif + + return (result.f); +} + +static inline void +double_to_foreign_endianness (union scm_ieee754_double *target, + double source) +{ + union scm_ieee754_double src; + + src.d = source; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + target->little_little_endian.negative = src.big_endian.negative; + target->little_little_endian.exponent = src.big_endian.exponent; + target->little_little_endian.mantissa0 = src.big_endian.mantissa0; + target->little_little_endian.mantissa1 = src.big_endian.mantissa1; +#else + target->big_endian.negative = src.little_little_endian.negative; + target->big_endian.exponent = src.little_little_endian.exponent; + target->big_endian.mantissa0 = src.little_little_endian.mantissa0; + target->big_endian.mantissa1 = src.little_little_endian.mantissa1; +#endif +} + +static inline double +double_from_foreign_endianness (const union scm_ieee754_double *source) +{ + union scm_ieee754_double result; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + result.big_endian.negative = source->little_little_endian.negative; + result.big_endian.exponent = source->little_little_endian.exponent; + result.big_endian.mantissa0 = source->little_little_endian.mantissa0; + result.big_endian.mantissa1 = source->little_little_endian.mantissa1; +#else + result.little_little_endian.negative = source->big_endian.negative; + result.little_little_endian.exponent = source->big_endian.exponent; + result.little_little_endian.mantissa0 = source->big_endian.mantissa0; + result.little_little_endian.mantissa1 = source->big_endian.mantissa1; +#endif + + return (result.d); +} + +/* Template macros to abstract over doubles and floats. + XXX: Guile can only convert to/from doubles. */ +#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type +#define IEEE754_TO_SCM(_c_type) scm_from_double +#define IEEE754_FROM_SCM(_c_type) scm_to_double +#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \ + _c_type ## _from_foreign_endianness +#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \ + _c_type ## _to_foreign_endianness + + +/* Templace getters and setters. */ + +#define IEEE754_ACCESSOR_PROLOGUE(_type) \ + INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed); + +#define IEEE754_REF(_type) \ + _type c_result; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + if (scm_is_eq (endianness, native_endianness)) \ + memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ + else \ + { \ + IEEE754_UNION (_type) c_raw; \ + \ + memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \ + c_result = \ + IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \ + } \ + \ + return (IEEE754_TO_SCM (_type) (c_result)); + +#define IEEE754_NATIVE_REF(_type) \ + _type c_result; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + \ + memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ + return (IEEE754_TO_SCM (_type) (c_result)); + +#define IEEE754_SET(_type) \ + _type c_value; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_REAL (3, value); \ + SCM_VALIDATE_SYMBOL (4, endianness); \ + c_value = IEEE754_FROM_SCM (_type) (value); \ + \ + if (scm_is_eq (endianness, native_endianness)) \ + memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \ + else \ + { \ + IEEE754_UNION (_type) c_raw; \ + \ + IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \ + memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \ + } \ + \ + return SCM_UNSPECIFIED; + +#define IEEE754_NATIVE_SET(_type) \ + _type c_value; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_REAL (3, value); \ + c_value = IEEE754_FROM_SCM (_type) (value); \ + \ + memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \ + return SCM_UNSPECIFIED; + + +/* Single precision. */ + +SCM_DEFINE (scm_bytevector_ieee_single_ref, + "bytevector-ieee-single-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the IEEE-754 single from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_ieee_single_ref +{ + IEEE754_REF (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_native_ref, + "bytevector-ieee-single-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the IEEE-754 single from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref +{ + IEEE754_NATIVE_REF (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_set_x, + "bytevector-ieee-single-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store real @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_ieee_single_set_x +{ + IEEE754_SET (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_native_set_x, + "bytevector-ieee-single-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the real @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x +{ + IEEE754_NATIVE_SET (float); +} +#undef FUNC_NAME + + +/* Double precision. */ + +SCM_DEFINE (scm_bytevector_ieee_double_ref, + "bytevector-ieee-double-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the IEEE-754 double from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_ieee_double_ref +{ + IEEE754_REF (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_native_ref, + "bytevector-ieee-double-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the IEEE-754 double from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref +{ + IEEE754_NATIVE_REF (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_set_x, + "bytevector-ieee-double-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store real @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_ieee_double_set_x +{ + IEEE754_SET (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_native_set_x, + "bytevector-ieee-double-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the real @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x +{ + IEEE754_NATIVE_SET (double); +} +#undef FUNC_NAME + + +#undef IEEE754_UNION +#undef IEEE754_TO_SCM +#undef IEEE754_FROM_SCM +#undef IEEE754_FROM_FOREIGN_ENDIANNESS +#undef IEEE754_TO_FOREIGN_ENDIANNESS +#undef IEEE754_REF +#undef IEEE754_NATIVE_REF +#undef IEEE754_SET +#undef IEEE754_NATIVE_SET + + +/* Operations on strings. */ + + +/* Produce a function that returns the length of a UTF-encoded string. */ +#define UTF_STRLEN_FUNCTION(_utf_width) \ +static inline size_t \ +utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \ +{ \ + size_t len = 0; \ + const uint ## _utf_width ## _t *ptr; \ + for (ptr = str; \ + *ptr != 0; \ + ptr++) \ + { \ + len++; \ + } \ + \ + return (len * ((_utf_width) / 8)); \ +} + +UTF_STRLEN_FUNCTION (8) + + +/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */ +#define UTF_STRLEN(_utf_width, _str) \ + utf ## _utf_width ## _strlen (_str) + +/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and + ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the + encoding name). */ +static inline void +utf_encoding_name (char *name, size_t utf_width, SCM endianness) +{ + strcpy (name, "UTF-"); + strcat (name, ((utf_width == 8) + ? "8" + : ((utf_width == 16) + ? "16" + : ((utf_width == 32) + ? "32" + : "??")))); + strcat (name, + ((scm_is_eq (endianness, scm_sym_big)) + ? "BE" + : ((scm_is_eq (endianness, scm_sym_little)) + ? "LE" + : "unknown"))); +} + +/* Maximum length of a UTF encoding name. */ +#define MAX_UTF_ENCODING_NAME_LEN 16 + +/* Produce the body of a `string->utf' function. */ +#define STRING_TO_UTF(_utf_width) \ + SCM utf; \ + int err; \ + char *c_str; \ + char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \ + char *c_utf = NULL, *c_locale; \ + size_t c_strlen, c_raw_strlen, c_utf_len = 0; \ + \ + SCM_VALIDATE_STRING (1, str); \ + if (endianness == SCM_UNDEFINED) \ + endianness = scm_sym_big; \ + else \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + \ + c_strlen = scm_c_string_length (str); \ + c_raw_strlen = c_strlen * ((_utf_width) / 8); \ + do \ + { \ + c_str = (char *) alloca (c_raw_strlen + 1); \ + c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \ + } \ + while (c_raw_strlen > c_strlen); \ + c_str[c_raw_strlen] = '\0'; \ + \ + utf_encoding_name (c_utf_name, (_utf_width), endianness); \ + \ + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \ + strcpy (c_locale, locale_charset ()); \ + \ + err = mem_iconveh (c_str, c_raw_strlen, \ + c_locale, c_utf_name, \ + iconveh_question_mark, NULL, \ + &c_utf, &c_utf_len); \ + if (SCM_UNLIKELY (err)) \ + scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \ + scm_list_1 (str), err); \ + else \ + /* C_UTF is null-terminated. */ \ + utf = scm_c_take_bytevector ((signed char *) c_utf, \ + c_utf_len); \ + \ + return (utf); + + + +SCM_DEFINE (scm_string_to_utf8, "string->utf8", + 1, 0, 0, + (SCM str), + "Return a newly allocated bytevector that contains the UTF-8 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf8 +{ + SCM utf; + char *c_str; + uint8_t *c_utf; + size_t c_strlen, c_raw_strlen; + + SCM_VALIDATE_STRING (1, str); + + c_strlen = scm_c_string_length (str); + c_raw_strlen = c_strlen; + do + { + c_str = (char *) alloca (c_raw_strlen + 1); + c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); + } + while (c_raw_strlen > c_strlen); + c_str[c_raw_strlen] = '\0'; + + c_utf = u8_strconv_from_locale (c_str); + if (SCM_UNLIKELY (c_utf == NULL)) + scm_syserror (FUNC_NAME); + else + /* C_UTF is null-terminated. */ + utf = scm_c_take_bytevector ((signed char *) c_utf, + UTF_STRLEN (8, c_utf)); + + return (utf); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_to_utf16, "string->utf16", + 1, 1, 0, + (SCM str, SCM endianness), + "Return a newly allocated bytevector that contains the UTF-16 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf16 +{ + STRING_TO_UTF (16); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_to_utf32, "string->utf32", + 1, 1, 0, + (SCM str, SCM endianness), + "Return a newly allocated bytevector that contains the UTF-32 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf32 +{ + STRING_TO_UTF (32); +} +#undef FUNC_NAME + + +/* Produce the body of a function that converts a UTF-encoded bytevector to a + string. */ +#define UTF_TO_STRING(_utf_width) \ + SCM str = SCM_BOOL_F; \ + int err; \ + char *c_str = NULL, *c_locale; \ + char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \ + const char *c_utf; \ + size_t c_strlen = 0, c_utf_len; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, utf); \ + if (endianness == SCM_UNDEFINED) \ + endianness = scm_sym_big; \ + else \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + \ + c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \ + c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \ + utf_encoding_name (c_utf_name, (_utf_width), endianness); \ + \ + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \ + strcpy (c_locale, locale_charset ()); \ + \ + err = mem_iconveh (c_utf, c_utf_len, \ + c_utf_name, c_locale, \ + iconveh_question_mark, NULL, \ + &c_str, &c_strlen); \ + if (SCM_UNLIKELY (err)) \ + scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \ + scm_list_1 (utf), err); \ + else \ + /* C_STR is null-terminated. */ \ + str = scm_take_locale_stringn (c_str, c_strlen); \ + \ + return (str); + + +SCM_DEFINE (scm_utf8_to_string, "utf8->string", + 1, 0, 0, + (SCM utf), + "Return a newly allocate string that contains from the UTF-8-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf8_to_string +{ + SCM str; + int err; + char *c_str = NULL, *c_locale; + const char *c_utf; + size_t c_utf_len, c_strlen = 0; + + SCM_VALIDATE_BYTEVECTOR (1, utf); + + c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); + + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); + strcpy (c_locale, locale_charset ()); + + c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); + err = mem_iconveh (c_utf, c_utf_len, + "UTF-8", c_locale, + iconveh_question_mark, NULL, + &c_str, &c_strlen); + if (SCM_UNLIKELY (err)) + scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", + scm_list_1 (utf), err); + else + /* C_STR is null-terminated. */ + str = scm_take_locale_stringn (c_str, c_strlen); + + return (str); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_utf16_to_string, "utf16->string", + 1, 1, 0, + (SCM utf, SCM endianness), + "Return a newly allocate string that contains from the UTF-16-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf16_to_string +{ + UTF_TO_STRING (16); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_utf32_to_string, "utf32->string", + 1, 1, 0, + (SCM utf, SCM endianness), + "Return a newly allocate string that contains from the UTF-32-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf32_to_string +{ + UTF_TO_STRING (32); +} +#undef FUNC_NAME + + + +/* Initialization. */ + +void +scm_init_bytevectors (void) +{ +#include "libguile/bytevectors.x" + +#ifdef WORDS_BIGENDIAN + native_endianness = scm_sym_big; +#else + native_endianness = scm_sym_little; +#endif + + scm_endianness_big = scm_sym_big; + scm_endianness_little = scm_sym_little; + + scm_null_bytevector = + scm_gc_protect_object (make_bytevector_from_buffer (0, NULL)); +} diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h new file mode 100644 index 000000000..98c38aca2 --- /dev/null +++ b/libguile/bytevectors.h @@ -0,0 +1,133 @@ +#ifndef SCM_BYTEVECTORS_H +#define SCM_BYTEVECTORS_H + +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 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" + + +/* R6RS bytevectors. */ + +#define SCM_BYTEVECTOR_LENGTH(_bv) \ + ((unsigned) SCM_SMOB_DATA (_bv)) +#define SCM_BYTEVECTOR_CONTENTS(_bv) \ + (SCM_BYTEVECTOR_INLINE_P (_bv) \ + ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \ + : (signed char *) SCM_SMOB_DATA_2 (_bv)) + + +SCM_API SCM scm_endianness_big; +SCM_API SCM scm_endianness_little; + +SCM_API SCM scm_make_bytevector (SCM, SCM); +SCM_API SCM scm_c_make_bytevector (unsigned); +SCM_API SCM scm_native_endianness (void); +SCM_API SCM scm_bytevector_p (SCM); +SCM_API SCM scm_bytevector_length (SCM); +SCM_API SCM scm_bytevector_eq_p (SCM, SCM); +SCM_API SCM scm_bytevector_fill_x (SCM, SCM); +SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_copy (SCM); + +SCM_API SCM scm_bytevector_to_u8_list (SCM); +SCM_API SCM scm_u8_list_to_bytevector (SCM); +SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_to_uint_list (SCM, SCM, SCM); +SCM_API SCM scm_sint_list_to_bytevector (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_to_sint_list (SCM, SCM, SCM); + +SCM_API SCM scm_bytevector_u16_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s16_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u32_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s32_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u64_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s64_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u8_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s8_ref (SCM, SCM); +SCM_API SCM scm_bytevector_uint_ref (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_sint_ref (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u8_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s8_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_uint_set_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_sint_set_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_string_to_utf8 (SCM); +SCM_API SCM scm_string_to_utf16 (SCM, SCM); +SCM_API SCM scm_string_to_utf32 (SCM, SCM); +SCM_API SCM scm_utf8_to_string (SCM); +SCM_API SCM scm_utf16_to_string (SCM, SCM); +SCM_API SCM scm_utf32_to_string (SCM, SCM); + + + +/* Internal API. */ + +/* The threshold (in octets) under which bytevectors are stored "in-line", + i.e., without allocating memory beside the SMOB itself (a double cell). + This optimization is necessary since small bytevectors are expected to be + common. */ +#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM)) +#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \ + ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD) +#define SCM_BYTEVECTOR_INLINE_P(_bv) \ + (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv))) + +/* Hint that is passed to `scm_gc_malloc ()' and friends. */ +#define SCM_GC_BYTEVECTOR "bytevector" + +SCM_API void scm_init_bytevectors (void); + +SCM_INTERNAL scm_t_bits scm_tc16_bytevector; +SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, unsigned); + +#define scm_c_shrink_bytevector(_bv, _len) \ + (SCM_BYTEVECTOR_INLINE_P (_bv) \ + ? (_bv) \ + : scm_i_shrink_bytevector ((_bv), (_len))) + +SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, unsigned); +SCM_INTERNAL SCM scm_null_bytevector; + +#endif /* SCM_BYTEVECTORS_H */ diff --git a/libguile/eval.c b/libguile/eval.c index 19ac0b155..05af5a1c5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2140,6 +2140,25 @@ unmemoize_at_call_with_values (const SCM expr, const SCM env) unmemoize_exprs (SCM_CDR (expr), env)); } +SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when); +SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when); +SCM_SYMBOL (sym_eval, "eval"); +SCM_SYMBOL (sym_load, "load"); + + +SCM +scm_m_eval_when (SCM expr, SCM env SCM_UNUSED) +{ + ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + + if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr))) + || scm_is_true (scm_memq (sym_load, scm_cadr (expr)))) + return scm_cons (SCM_IM_BEGIN, scm_cddr (expr)); + + return scm_list_1 (SCM_IM_BEGIN); +} + #if 0 /* See futures.h for a comment why futures are not enabled. diff --git a/libguile/eval.h b/libguile/eval.h index f3ec2e19c..b017f2e02 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -100,6 +100,7 @@ SCM_API SCM scm_sym_atapply; SCM_API SCM scm_sym_atcall_cc; SCM_API SCM scm_sym_at_call_with_values; SCM_API SCM scm_sym_delay; +SCM_API SCM scm_sym_eval_when; SCM_API SCM scm_sym_arrow; SCM_API SCM scm_sym_else; SCM_API SCM scm_sym_apply; @@ -146,6 +147,7 @@ SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env); SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env); SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env); SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env); +SCM_API SCM scm_m_eval_when (SCM xorig, SCM env); SCM_API int scm_badargsp (SCM formals, SCM args); SCM_API SCM scm_call_0 (SCM proc); SCM_API SCM scm_call_1 (SCM proc, SCM arg1); diff --git a/libguile/frames.c b/libguile/frames.c index f53cade95..c08fd3134 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 @@ -45,6 +21,7 @@ #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "frames.h" diff --git a/libguile/frames.h b/libguile/frames.h index 836763700..d74476ac8 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software 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 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 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, + * 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_FRAMES_H_ #define _SCM_FRAMES_H_ @@ -97,7 +73,7 @@ * Heap frames */ -extern scm_t_bits scm_tc16_vm_frame; +SCM_API scm_t_bits scm_tc16_vm_frame; struct scm_vm_frame { @@ -118,24 +94,24 @@ struct scm_vm_frame #define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P) /* FIXME rename scm_byte_t */ -extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, +SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, scm_byte_t *ip, scm_t_ptrdiff offset); -extern SCM scm_vm_frame_p (SCM obj); -extern SCM scm_vm_frame_program (SCM frame); -extern SCM scm_vm_frame_arguments (SCM frame); -extern SCM scm_vm_frame_source (SCM frame); -extern SCM scm_vm_frame_local_ref (SCM frame, SCM index); -extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); -extern SCM scm_vm_frame_return_address (SCM frame); -extern SCM scm_vm_frame_mv_return_address (SCM frame); -extern SCM scm_vm_frame_dynamic_link (SCM frame); -extern SCM scm_vm_frame_external_link (SCM frame); -extern SCM scm_vm_frame_stack (SCM frame); +SCM_API SCM scm_vm_frame_p (SCM obj); +SCM_API SCM scm_vm_frame_program (SCM frame); +SCM_API SCM scm_vm_frame_arguments (SCM frame); +SCM_API SCM scm_vm_frame_source (SCM frame); +SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index); +SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); +SCM_API SCM scm_vm_frame_return_address (SCM frame); +SCM_API SCM scm_vm_frame_mv_return_address (SCM frame); +SCM_API SCM scm_vm_frame_dynamic_link (SCM frame); +SCM_API SCM scm_vm_frame_external_link (SCM frame); +SCM_API SCM scm_vm_frame_stack (SCM frame); -extern SCM scm_c_vm_frame_prev (SCM frame); +SCM_API SCM scm_c_vm_frame_prev (SCM frame); -extern void scm_bootstrap_frames (void); -extern void scm_init_frames (void); +SCM_INTERNAL void scm_bootstrap_frames (void); +SCM_INTERNAL void scm_init_frames (void); #endif /* _SCM_FRAMES_H_ */ diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h new file mode 100644 index 000000000..e345efaae --- /dev/null +++ b/libguile/ieee-754.h @@ -0,0 +1,90 @@ +/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc. + This file is part of 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 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, write to the Free + Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307 USA. */ + +#ifndef SCM_IEEE_754_H +#define SCM_IEEE_754_H 1 + +/* Based on glibc's and modified by Ludovic Courtès to include + all possible IEEE-754 double-precision representations. */ + + +/* IEEE 754 simple-precision format (32-bit). */ + +union scm_ieee754_float + { + float f; + + struct + { + unsigned int negative:1; + unsigned int exponent:8; + unsigned int mantissa:23; + } big_endian; + + struct + { + unsigned int mantissa:23; + unsigned int exponent:8; + unsigned int negative:1; + } little_endian; + }; + + + +/* IEEE 754 double-precision format (64-bit). */ + +union scm_ieee754_double + { + double d; + + struct + { + /* Big endian. */ + + unsigned int negative:1; + unsigned int exponent:11; + /* Together these comprise the mantissa. */ + unsigned int mantissa0:20; + unsigned int mantissa1:32; + } big_endian; + + struct + { + /* Both byte order and word order are little endian. */ + + /* Together these comprise the mantissa. */ + unsigned int mantissa1:32; + unsigned int mantissa0:20; + unsigned int exponent:11; + unsigned int negative:1; + } little_little_endian; + + struct + { + /* Byte order is little endian but word order is big endian. Not + sure this is very wide spread. */ + unsigned int mantissa0:20; + unsigned int exponent:11; + unsigned int negative:1; + unsigned int mantissa1:32; + } little_big_endian; + + }; + + +#endif /* SCM_IEEE_754_H */ diff --git a/libguile/instructions.c b/libguile/instructions.c index 4f504f0a2..f0f52e422 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -1,49 +1,27 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 #include + +#include "_scm.h" #include "vm-bootstrap.h" #include "instructions.h" diff --git a/libguile/instructions.h b/libguile/instructions.h index 4968671b5..f4f45b371 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_INSTRUCTIONS_H_ #define _SCM_INSTRUCTIONS_H_ @@ -57,16 +33,16 @@ enum scm_opcode { scm_op_last = SCM_VM_NUM_INSTRUCTIONS }; -extern SCM scm_instruction_list (void); -extern SCM scm_instruction_p (SCM obj); -extern SCM scm_instruction_length (SCM inst); -extern SCM scm_instruction_pops (SCM inst); -extern SCM scm_instruction_pushes (SCM inst); -extern SCM scm_instruction_to_opcode (SCM inst); -extern SCM scm_opcode_to_instruction (SCM op); +SCM_API SCM scm_instruction_list (void); +SCM_API SCM scm_instruction_p (SCM obj); +SCM_API SCM scm_instruction_length (SCM inst); +SCM_API SCM scm_instruction_pops (SCM inst); +SCM_API SCM scm_instruction_pushes (SCM inst); +SCM_API SCM scm_instruction_to_opcode (SCM inst); +SCM_API SCM scm_opcode_to_instruction (SCM op); -extern void scm_bootstrap_instructions (void); -extern void scm_init_instructions (void); +SCM_INTERNAL void scm_bootstrap_instructions (void); +SCM_INTERNAL void scm_init_instructions (void); #endif /* _SCM_INSTRUCTIONS_H_ */ diff --git a/libguile/macros.c b/libguile/macros.c index d132c0159..ca3e83e29 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -48,10 +48,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate) || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, macro, port, pstate))) { + scm_puts ("#<", port); + + if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) + scm_puts ("extended-", port); + if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) - scm_puts ("#', port); } return 1; } +static SCM +macro_mark (SCM macro) +{ + if (SCM_MACRO_IS_EXTENDED (macro)) + { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro)); + scm_gc_mark (SCM_SMOB_OBJECT_3 (macro)); + } + return SCM_SMOB_OBJECT (macro); +} + static SCM makmac (SCM code, scm_t_bits flags) { @@ -164,11 +187,45 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, #endif +SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0, + (SCM type, SCM binding), + "Return a @dfn{macro} that requires expansion by syntax-case.\n" + "While users should not call this function, it is useful to know\n" + "that syntax-case macros are represented as Guile primitive macros.") +#define FUNC_NAME s_scm_make_syncase_macro +{ + SCM z; + SCM_VALIDATE_SYMBOL (1, type); + + SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type), + SCM_UNPACK (binding)); + SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED); + return z; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0, + (SCM m, SCM type, SCM binding), + "Extend a core macro @var{m} with a syntax-case binding.") +#define FUNC_NAME s_scm_make_extended_syncase_macro +{ + SCM z; + SCM_VALIDATE_SMOB (1, m, macro); + SCM_VALIDATE_SYMBOL (2, type); + + SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type), + SCM_UNPACK (binding)); + SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED); + return z; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, (SCM obj), - "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n" - "syntax transformer.") + "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n" + "syntax transformer, or a syntax-case macro.") #define FUNC_NAME s_scm_macro_p { return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj)); @@ -182,14 +239,15 @@ SCM_SYMBOL (scm_sym_macro, "macro"); #endif SCM_SYMBOL (scm_sym_mmacro, "macro!"); SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!"); +SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro"); SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, (SCM m), - "Return one of the symbols @code{syntax}, @code{macro} or\n" - "@code{macro!}, depending on whether @var{m} is a syntax\n" - "transformer, a regular macro, or a memoizing macro,\n" - "respectively. If @var{m} is not a macro, @code{#f} is\n" - "returned.") + "Return one of the symbols @code{syntax}, @code{macro},\n" + "@code{macro!}, or @code{syntax-case}, depending on whether\n" + "@var{m} is a syntax transformer, a regular macro, a memoizing\n" + "macro, or a syntax-case macro, respectively. If @var{m} is\n" + "not a macro, @code{#f} is returned.") #define FUNC_NAME s_scm_macro_type { if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m)) @@ -202,6 +260,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, #endif case 2: return scm_sym_mmacro; case 3: return scm_sym_bimacro; + case 4: return scm_sym_syncase_macro; default: scm_wrong_type_arg (FUNC_NAME, 1, m); } } @@ -214,7 +273,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, #define FUNC_NAME s_scm_macro_name { SCM_VALIDATE_SMOB (1, m, macro); - return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m))); + if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m)))) + return scm_procedure_name (SCM_SMOB_OBJECT (m)); + return SCM_BOOL_F; } #undef FUNC_NAME @@ -236,6 +297,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0, + (SCM m), + "Return the type of the macro @var{m}.") +#define FUNC_NAME s_scm_syncase_macro_type +{ + SCM_VALIDATE_SMOB (1, m, macro); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_2 (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0, + (SCM m), + "Return the binding of the macro @var{m}.") +#define FUNC_NAME s_scm_syncase_macro_binding +{ + SCM_VALIDATE_SMOB (1, m, macro); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_3 (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + SCM scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { @@ -249,7 +338,7 @@ void scm_init_macros () { scm_tc16_macro = scm_make_smob_type ("macro", 0); - scm_set_smob_mark (scm_tc16_macro, scm_markcdr); + scm_set_smob_mark (scm_tc16_macro, macro_mark); scm_set_smob_print (scm_tc16_macro, macro_print); #include "libguile/macros.x" } diff --git a/libguile/macros.h b/libguile/macros.h index e1de77ff9..5e3d64a55 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -29,9 +29,15 @@ #define SCM_ASSYNT(_cond, _msg, _subr) \ if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); +#define SCM_MACRO_TYPE_BITS (3) +#define SCM_MACRO_TYPE_MASK ((1< @@ -51,6 +27,7 @@ #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "programs.h" #include "objcodes.h" diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 222691668..acd43a600 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software 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 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 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, + * 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_OBJCODES_H_ #define _SCM_OBJCODES_H_ @@ -60,7 +36,7 @@ struct scm_objcode { #define SCM_F_OBJCODE_IS_U8VECTOR (1<<1) #define SCM_F_OBJCODE_IS_SLICE (1<<2) -extern scm_t_bits scm_tc16_objcode; +SCM_API scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x)) #define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x)) @@ -80,15 +56,15 @@ extern scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE) SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr); -extern SCM scm_load_objcode (SCM file); -extern SCM scm_objcode_p (SCM obj); -extern SCM scm_objcode_meta (SCM objcode); -extern SCM scm_bytecode_to_objcode (SCM bytecode); -extern SCM scm_objcode_to_bytecode (SCM objcode); -extern SCM scm_write_objcode (SCM objcode, SCM port); +SCM_API SCM scm_load_objcode (SCM file); +SCM_API SCM scm_objcode_p (SCM obj); +SCM_API SCM scm_objcode_meta (SCM objcode); +SCM_API SCM scm_bytecode_to_objcode (SCM bytecode); +SCM_API SCM scm_objcode_to_bytecode (SCM objcode); +SCM_API SCM scm_write_objcode (SCM objcode, SCM port); -extern void scm_bootstrap_objcodes (void); -extern void scm_init_objcodes (void); +SCM_INTERNAL void scm_bootstrap_objcodes (void); +SCM_INTERNAL void scm_init_objcodes (void); #endif /* _SCM_OBJCODES_H_ */ diff --git a/libguile/posix.c b/libguile/posix.c index 2799209d9..5e6f05fb7 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -101,8 +101,6 @@ extern char *ttyname(); #include -extern char ** environ; - #ifdef HAVE_GRP_H #include #endif @@ -140,10 +138,6 @@ extern char ** environ; #include /* from Gnulib */ -#if HAVE_CRT_EXTERNS_H -#include /* for Darwin _NSGetEnviron */ -#endif - /* Some Unix systems don't define these. CPP hair is dangerous, but this seems safe enough... */ #ifndef R_OK @@ -196,13 +190,6 @@ int sethostname (char *name, size_t namelen); -/* On Apple Darwin in a shared library there's no "environ" to access - directly, instead the address of that variable must be obtained with - _NSGetEnviron(). */ -#if HAVE__NSGETENVIRON && defined (PIC) -#define environ (*_NSGetEnviron()) -#endif - /* Two often used patterns diff --git a/libguile/programs.c b/libguile/programs.c index 8e8982994..68e0b8541 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,49 +1,26 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 #include +#include "_scm.h" #include "vm-bootstrap.h" #include "instructions.h" #include "modules.h" diff --git a/libguile/programs.h b/libguile/programs.h index 68a6936a2..ae819ef85 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_PROGRAMS_H_ #define _SCM_PROGRAMS_H_ @@ -51,7 +27,7 @@ typedef unsigned char scm_byte_t; -extern scm_t_bits scm_tc16_program; +SCM_API scm_t_bits scm_tc16_program; #define SCM_F_PROGRAM_IS_BOOT (1<<0) @@ -63,27 +39,27 @@ extern scm_t_bits scm_tc16_program; #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) #define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT) -extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); +SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); -extern SCM scm_program_p (SCM obj); -extern SCM scm_program_base (SCM program); -extern SCM scm_program_arity (SCM program); -extern SCM scm_program_meta (SCM program); -extern SCM scm_program_bindings (SCM program); -extern SCM scm_program_sources (SCM program); -extern SCM scm_program_source (SCM program, SCM ip); -extern SCM scm_program_properties (SCM program); -extern SCM scm_program_name (SCM program); -extern SCM scm_program_objects (SCM program); -extern SCM scm_program_module (SCM program); -extern SCM scm_program_external (SCM program); -extern SCM scm_program_external_set_x (SCM program, SCM external); -extern SCM scm_program_objcode (SCM program); +SCM_API SCM scm_program_p (SCM obj); +SCM_API SCM scm_program_base (SCM program); +SCM_API SCM scm_program_arity (SCM program); +SCM_API SCM scm_program_meta (SCM program); +SCM_API SCM scm_program_bindings (SCM program); +SCM_API SCM scm_program_sources (SCM program); +SCM_API SCM scm_program_source (SCM program, SCM ip); +SCM_API SCM scm_program_properties (SCM program); +SCM_API SCM scm_program_name (SCM program); +SCM_API SCM scm_program_objects (SCM program); +SCM_API SCM scm_program_module (SCM program); +SCM_API SCM scm_program_external (SCM program); +SCM_API SCM scm_program_external_set_x (SCM program, SCM external); +SCM_API SCM scm_program_objcode (SCM program); -extern SCM scm_c_program_source (SCM program, size_t ip); +SCM_API SCM scm_c_program_source (SCM program, size_t ip); -extern void scm_bootstrap_programs (void); -extern void scm_init_programs (void); +SCM_INTERNAL void scm_bootstrap_programs (void); +SCM_INTERNAL void scm_init_programs (void); #endif /* _SCM_PROGRAMS_H_ */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c new file mode 100644 index 000000000..a07636fce --- /dev/null +++ b/libguile/r6rs-ports.c @@ -0,0 +1,1118 @@ +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 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 + +#ifdef HAVE_UNISTD_H +# include +#endif + +#include +#include +#include + +#include "libguile/_scm.h" +#include "libguile/bytevectors.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/r6rs-ports.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/values.h" +#include "libguile/vectors.h" + + + +/* Unimplemented features. */ + + +/* Transoders are currently not implemented since Guile 1.8 is not + Unicode-capable. Thus, most of the code here assumes the use of the + binary transcoder. */ +static inline void +transcoders_not_implemented (void) +{ + fprintf (stderr, "%s: warning: transcoders not implemented\n", + PACKAGE_NAME); +} + + +/* End-of-file object. */ + +SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, + (void), + "Return the end-of-file object.") +#define FUNC_NAME s_scm_eof_object +{ + 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; + +static inline SCM +make_bip (SCM bv) +{ + SCM port; + char *c_bv; + unsigned c_len; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + + port = scm_new_port_table_entry (bytevector_input_port_type); + + /* Prevent BV from being GC'd. */ + SCM_SETSTREAM (port, SCM_UNPACK (bv)); + + /* Have the port directly access the bytevector. */ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + c_port = SCM_PTAB_ENTRY (port); + 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; + + /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ + SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits); + + return port; +} + +static SCM +bip_mark (SCM port) +{ + /* Mark the underlying bytevector. */ + return (SCM_PACK (SCM_STREAM (port))); +} + +static int +bip_fill_input (SCM port) +{ + int result; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + if (c_port->read_pos >= c_port->read_end) + result = EOF; + else + result = (int) *c_port->read_pos; + + return result; +} + +static off_t +bip_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "bip_seek" +{ + off_t c_result = 0; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + switch (whence) + { + case SEEK_CUR: + offset += c_port->read_pos - c_port->read_buf; + /* Fall through. */ + + 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; + + 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; +} +#undef FUNC_NAME + + +/* Instantiate the bytevector input port type. */ +static inline void +initialize_bytevector_input_ports (void) +{ + bytevector_input_port_type = + scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input, + NULL); + + scm_set_port_mark (bytevector_input_port_type, bip_mark); + scm_set_port_seek (bytevector_input_port_type, bip_seek); +} + + +SCM_DEFINE (scm_open_bytevector_input_port, + "open-bytevector-input-port", 1, 1, 0, + (SCM bv, SCM transcoder), + "Return an input port whose contents are drawn from " + "bytevector @var{bv}.") +#define FUNC_NAME s_scm_open_bytevector_input_port +{ + SCM_VALIDATE_BYTEVECTOR (1, bv); + if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) + transcoders_not_implemented (); + + return (make_bip (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) + +static SCM +cbp_mark (SCM port) +{ + /* Mark the underlying method and object vector. */ + return (SCM_PACK (SCM_STREAM (port))); +} + +static off_t +cbp_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "cbp_seek" +{ + SCM result; + off_t 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); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary port does not " + "support `port-position'"); + + offset += scm_to_int (result); + /* Fall through. */ + } + + 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)); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary port does not " + "support `set-port-position!'"); + + /* Assuming setting the position succeeded. */ + c_result = offset; + break; + } + + default: + /* `SEEK_END' cannot be supported. */ + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary ports do not " + "support `SEEK_END'"); + } + + return c_result; +} +#undef FUNC_NAME + +static int +cbp_close (SCM port) +{ + SCM close_proc; + + close_proc = SCM_CBP_CLOSE_PROC (port); + if (scm_is_true (close_proc)) + /* Invoke the `close' thunk. */ + scm_call_0 (close_proc); + + return 1; +} + + +/* Custom binary input port ("cbip" for short). */ + +static scm_t_bits custom_binary_input_port_type = 0; + +/* Size of the buffer embedded in custom binary input ports. */ +#define CBIP_BUFFER_SIZE 4096 + +/* Return the bytevector associated with PORT. */ +#define SCM_CBIP_BYTEVECTOR(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4) + +/* Return the various procedures of PORT. */ +#define SCM_CBIP_READ_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) + + +static inline SCM +make_cbip (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; + + /* 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); + + /* 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_new_port_table_entry (custom_binary_input_port_type); + + /* Attach it the method vector. */ + SCM_SETSTREAM (port, SCM_UNPACK (method_vector)); + + /* Have the port directly access the buffer (bytevector). */ + c_port = SCM_PTAB_ENTRY (port); + 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; + + /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ + SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits); + + return port; +} + +static int +cbip_fill_input (SCM port) +#define FUNC_NAME "cbip_fill_input" +{ + int result; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + again: + if (c_port->read_pos >= c_port->read_end) + { + /* Invoke the user's `read!' procedure. */ + unsigned c_octets; + SCM bv, read_proc, octets; + + /* Use the bytevector associated with PORT as the buffer passed to the + `read!' procedure, thereby avoiding additional allocations. */ + bv = SCM_CBIP_BYTEVECTOR (port); + read_proc = SCM_CBIP_READ_PROC (port); + + /* The assumption here is that C_PORT's internal buffer wasn't changed + behind our back. */ + assert (c_port->read_buf == + (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); + assert ((unsigned) c_port->read_buf_size + == SCM_BYTEVECTOR_LENGTH (bv)); + + octets = scm_call_3 (read_proc, bv, SCM_INUM0, + SCM_I_MAKINUM (CBIP_BUFFER_SIZE)); + c_octets = scm_to_uint (octets); + + c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_port->read_end = (unsigned char *) c_port->read_pos + c_octets; + + if (c_octets > 0) + goto again; + else + result = EOF; + } + else + result = (int) *c_port->read_pos; + + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_custom_binary_input_port, + "make-custom-binary-input-port", 5, 0, 0, + (SCM id, SCM read_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary input port whose input is drained " + "by invoking @var{read_proc} and passing it a bytevector, an " + "index where octets should be written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_input_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, read_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (3, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (4, set_position_proc); + + 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)); +} +#undef FUNC_NAME + + +/* Instantiate the custom binary input port type. */ +static inline void +initialize_custom_binary_input_ports (void) +{ + custom_binary_input_port_type = + scm_make_port_type ("r6rs-custom-binary-input-port", + cbip_fill_input, NULL); + + scm_set_port_mark (custom_binary_input_port_type, cbp_mark); + scm_set_port_seek (custom_binary_input_port_type, cbp_seek); + scm_set_port_close (custom_binary_input_port_type, cbp_close); +} + + + +/* Binary input. */ + +/* We currently don't support specific binary input ports. */ +#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT + +SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0, + (SCM port), + "Read an octet from @var{port}, a binary input port, " + "blocking as necessary.") +#define FUNC_NAME s_scm_get_u8 +{ + SCM result; + int c_result; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_result = scm_getc (port); + if (c_result == EOF) + result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM ((unsigned char) c_result); + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0, + (SCM port), + "Like @code{get-u8} but does not update @var{port} to " + "point past the octet.") +#define FUNC_NAME s_scm_lookahead_u8 +{ + SCM result; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + result = scm_peek_char (port); + if (SCM_CHARP (result)) + result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result)); + else + result = SCM_EOF_VAL; + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, + (SCM port, SCM 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.") +#define FUNC_NAME s_scm_get_bytevector_n +{ + SCM result; + char *c_bv; + unsigned c_count; + size_t c_read; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + 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 (port, c_bv, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read = 0; + + if ((c_read == 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result = SCM_EOF_VAL; + else + result = scm_null_bytevector; + } + else + { + if (c_read < c_count) + result = scm_c_shrink_bytevector (result, c_read); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, + (SCM port, SCM bv, SCM start, SCM 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.") +#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; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + 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 (port, c_bv + c_start, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read = 0; + + if ((c_read == 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM (0); + } + else + result = scm_from_size_t (c_read); + + return result; +} +#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 data " + "are available or and end-of-file is reached. Return either " + "a new bytevector containing the data read or the " + "end-of-file object.") +#define FUNC_NAME s_scm_get_bytevector_some +{ + /* Read at least one byte, unless the end-of-file is already reached, and + read while characters are available (buffered). */ + + SCM result; + char *c_bv; + unsigned c_len; + size_t c_total; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_len = 4096; + c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_total = 0; + + do + { + int c_chr; + + if (c_total + 1 > c_len) + { + /* Grow the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_len *= 2; + } + + /* We can't use `scm_c_read ()' since it blocks. */ + c_chr = scm_getc (port); + if (c_chr != EOF) + { + c_bv[c_total] = (char) c_chr; + c_total++; + } + } + while ((scm_is_true (scm_char_ready_p (port))) + && (!SCM_EOF_OBJECT_P (scm_peek_char (port)))); + + 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; + } + + result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, + (SCM 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).") +#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 (c_len, SCM_GC_BYTEVECTOR); + c_total = c_read = 0; + + do + { + 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); + 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 (port, c_bv + c_total, c_count); + c_total += c_read, c_count -= c_read; + } + while (!SCM_EOF_OBJECT_P (scm_peek_char (port))); + + 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; + } + + result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + + + +/* Binary output. */ + +/* We currently don't support specific binary input ports. */ +#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT + + +SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0, + (SCM port, SCM octet), + "Write @var{octet} to binary port @var{port}.") +#define FUNC_NAME s_scm_put_u8 +{ + scm_t_uint8 c_octet; + + SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); + c_octet = scm_to_uint8 (octet); + + scm_putc ((char) c_octet, port); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, + (SCM port, SCM bv, SCM start, SCM count), + "Write the contents of @var{bv} to @var{port}, optionally " + "starting at index @var{start} and limiting to @var{count} " + "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 (start != SCM_UNDEFINED) + { + c_start = scm_to_uint (start); + + if (count != SCM_UNDEFINED) + { + c_count = scm_to_uint (count); + if (SCM_UNLIKELY (c_start + c_count > c_len)) + scm_out_of_range (FUNC_NAME, count); + } + else + { + if (SCM_UNLIKELY (c_start >= c_len)) + scm_out_of_range (FUNC_NAME, start); + else + c_count = c_len - c_start; + } + } + else + c_start = 0, c_count = c_len; + + scm_c_write (port, c_bv + c_start, c_count); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* Bytevector output port ("bop" for short). */ + +/* Implementation of "bops". + + 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. + + XXX: Access to a bop's internal buffer is not thread-safe. */ + +static scm_t_bits 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 + +/* Representation of a bop's internal buffer. */ +typedef struct +{ + size_t total_len; + size_t len; + size_t pos; + char *buffer; +} scm_t_bop_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) \ + (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf))) + + +static inline void +bop_buffer_init (scm_t_bop_buffer *buf) +{ + buf->total_len = buf->len = buf->pos = 0; + buf->buffer = NULL; +} + +static inline void +bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size) +{ + char *new_buf; + size_t new_size; + + for (new_size = buf->total_len + ? buf->total_len : SCM_BOP_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); + else + new_buf = scm_gc_malloc (new_size, SCM_GC_BOP); + + buf->buffer = new_buf; + buf->total_len = new_size; +} + +static inline SCM +make_bop (void) +{ + SCM port, bop_proc; + scm_t_port *c_port; + scm_t_bop_buffer *buf; + const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + + port = scm_new_port_table_entry (bytevector_output_port_type); + + buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP); + bop_buffer_init (buf); + + c_port = SCM_PTAB_ENTRY (port); + c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; + c_port->write_buf_size = 0; + + SCM_SET_BOP_BUFFER (port, buf); + + /* Mark PORT as open and writable. */ + SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits); + + /* Make the bop procedure. */ + SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, + SCM_PACK (port)); + + return (scm_values (scm_list_2 (port, bop_proc))); +} + +static size_t +bop_free (SCM port) +{ + /* The port itself is necessarily freed _after_ the bop proc, since the bop + proc holds a reference to it. Thus we can safely free the internal + buffer when the bop becomes unreferenced. */ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + if (buf->buffer) + scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP); + + scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP); + + return 0; +} + +/* Write SIZE octets from DATA to PORT. */ +static void +bop_write (SCM port, const void *data, size_t size) +{ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + + if (buf->pos + size > buf->total_len) + bop_buffer_grow (buf, buf->pos + size); + + memcpy (buf->buffer + buf->pos, data, size); + buf->pos += size; + buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; +} + +static off_t +bop_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "bop_seek" +{ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + switch (whence) + { + case SEEK_CUR: + offset += (off_t) buf->pos; + /* Fall through. */ + + case SEEK_SET: + if (offset < 0 || (unsigned) offset > buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = offset; + break; + + 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; + + default: + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "invalid `seek' parameter"); + } + + return buf->pos; +} +#undef FUNC_NAME + +/* Fetch data from a bop. */ +SCM_SMOB_APPLY (bytevector_output_port_procedure, + bop_proc_apply, 0, 0, 0, (SCM bop_proc)) +{ + SCM port, bv; + scm_t_bop_buffer *buf, result_buf; + + port = SCM_PACK (SCM_SMOB_DATA (bop_proc)); + buf = SCM_BOP_BUFFER (port); + + result_buf = *buf; + bop_buffer_init (buf); + + if (result_buf.len == 0) + bv = scm_c_take_bytevector (NULL, 0); + else + { + if (result_buf.total_len > result_buf.len) + /* Shrink the buffer. */ + result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer, + result_buf.total_len, + result_buf.len, + SCM_GC_BOP); + + bv = scm_c_take_bytevector ((signed char *) result_buf.buffer, + result_buf.len); + } + + return bv; +} + +SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark, + bop_proc) +{ + /* Mark the port associated with BOP_PROC. */ + return (SCM_PACK (SCM_SMOB_DATA (bop_proc))); +} + + +SCM_DEFINE (scm_open_bytevector_output_port, + "open-bytevector-output-port", 0, 1, 0, + (SCM transcoder), + "Return two values: an output port and a procedure. The latter " + "should be called with zero arguments to obtain a bytevector " + "containing the data accumulated by the port.") +#define FUNC_NAME s_scm_open_bytevector_output_port +{ + if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) + transcoders_not_implemented (); + + return (make_bop ()); +} +#undef FUNC_NAME + +static inline void +initialize_bytevector_output_ports (void) +{ + bytevector_output_port_type = + scm_make_port_type ("r6rs-bytevector-output-port", + NULL, bop_write); + + scm_set_port_seek (bytevector_output_port_type, bop_seek); + scm_set_port_free (bytevector_output_port_type, bop_free); +} + + +/* Custom binary output port ("cbop" for short). */ + +static scm_t_bits custom_binary_output_port_type; + +/* Return the various procedures of PORT. */ +#define SCM_CBOP_WRITE_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) + + +static inline SCM +make_cbop (SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) +{ + SCM port, method_vector; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + + /* Store the various methods and bytevector in a vector. */ + method_vector = scm_c_make_vector (4, SCM_BOOL_F); + SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + + port = scm_new_port_table_entry (custom_binary_output_port_type); + + /* Attach it the method vector. */ + SCM_SETSTREAM (port, SCM_UNPACK (method_vector)); + + /* Have the port directly access the buffer (bytevector). */ + c_port = SCM_PTAB_ENTRY (port); + c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; + c_port->write_buf_size = c_port->read_buf_size = 0; + + /* Mark PORT as open, writable and unbuffered. */ + SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits); + + return port; +} + +/* Write SIZE octets from DATA to PORT. */ +static void +cbop_write (SCM port, const void *data, size_t size) +#define FUNC_NAME "cbop_write" +{ + long int c_result; + size_t c_written; + SCM bv, write_proc, 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); + + write_proc = SCM_CBOP_WRITE_PROC (port); + + /* Since the `write' procedure of Guile's ports has type `void', it must + try hard to write exactly SIZE bytes, regardless of how many bytes the + sink can handle. */ + 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"); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_custom_binary_output_port, + "make-custom-binary-output-port", 5, 0, 0, + (SCM id, SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary output port whose output is drained " + "by invoking @var{write_proc} and passing it a bytevector, an " + "index where octets should be written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_output_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, write_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (3, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (4, set_position_proc); + + 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)); +} +#undef FUNC_NAME + + +/* Instantiate the custom binary output port type. */ +static inline void +initialize_custom_binary_output_ports (void) +{ + custom_binary_output_port_type = + scm_make_port_type ("r6rs-custom-binary-output-port", + NULL, cbop_write); + + scm_set_port_mark (custom_binary_output_port_type, cbp_mark); + scm_set_port_seek (custom_binary_output_port_type, cbp_seek); + scm_set_port_close (custom_binary_output_port_type, cbp_close); +} + + +/* Initialization. */ + +void +scm_init_r6rs_ports (void) +{ +#include "r6rs-ports.x" + + initialize_bytevector_input_ports (); + initialize_custom_binary_input_ports (); + initialize_bytevector_output_ports (); + initialize_custom_binary_output_ports (); +} diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h new file mode 100644 index 000000000..e29d96200 --- /dev/null +++ b/libguile/r6rs-ports.h @@ -0,0 +1,43 @@ +#ifndef SCM_R6RS_PORTS_H +#define SCM_R6RS_PORTS_H + +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 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" + +/* R6RS I/O Ports. */ + +SCM_API SCM scm_eof_object (void); +SCM_API SCM scm_open_bytevector_input_port (SCM, SCM); +SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_u8 (SCM); +SCM_API SCM scm_lookahead_u8 (SCM); +SCM_API SCM scm_get_bytevector_n (SCM, SCM); +SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_bytevector_some (SCM); +SCM_API SCM scm_get_bytevector_all (SCM); +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 void scm_init_r6rs_ports (void); + +#endif /* SCM_R6RS_PORTS_H */ diff --git a/libguile/read.c b/libguile/read.c index 61806f263..3493ba03f 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -182,6 +182,7 @@ static SCM *scm_read_hash_procedures; /* Read an SCSH block comment. */ static inline SCM scm_read_scsh_block_comment (int chr, SCM port); +static SCM scm_read_commented_expression (int chr, SCM port); /* Read from PORT until a delimiter (e.g., a whitespace) is read. Return zero if the whole token fits in BUF, non-zero otherwise. */ @@ -257,6 +258,9 @@ flush_ws (SCM port, const char *eoferr) case '!': scm_read_scsh_block_comment (c, port); break; + case ';': + scm_read_commented_expression (c, port); + break; default: scm_ungetc (c, port); return '#'; @@ -700,6 +704,65 @@ scm_read_quote (int chr, SCM port) return p; } +SCM_SYMBOL (sym_syntax, "syntax"); +SCM_SYMBOL (sym_quasisyntax, "quasisyntax"); +SCM_SYMBOL (sym_unsyntax, "unsyntax"); +SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing"); + +static SCM +scm_read_syntax (int chr, SCM port) +{ + SCM p; + long line = SCM_LINUM (port); + int column = SCM_COL (port) - 1; + + switch (chr) + { + case '`': + p = sym_quasisyntax; + break; + + case '\'': + p = sym_syntax; + break; + + case ',': + { + int c; + + c = scm_getc (port); + if ('@' == c) + p = sym_unsyntax_splicing; + else + { + scm_ungetc (c, port); + p = sym_unsyntax; + } + break; + } + + default: + fprintf (stderr, "%s: unhandled syntax character (%i)\n", + "scm_read_syntax", chr); + abort (); + } + + p = scm_cons2 (p, scm_read_expression (port), SCM_EOL); + if (SCM_RECORD_POSITIONS_P) + scm_whash_insert (scm_source_whash, p, + scm_make_srcprops (line, column, + SCM_FILENAME (port), + SCM_COPY_SOURCE_P + ? (scm_cons2 (SCM_CAR (p), + SCM_CAR (SCM_CDR (p)), + SCM_EOL)) + : SCM_UNDEFINED, + SCM_EOL)); + + + return p; +} + static inline SCM scm_read_semicolon_comment (int chr, SCM port) { @@ -862,6 +925,20 @@ scm_read_scsh_block_comment (int chr, SCM port) return SCM_UNSPECIFIED; } +static SCM +scm_read_commented_expression (int chr, SCM port) +{ + int c; + + c = flush_ws (port, (char *) NULL); + if (EOF == c) + scm_i_input_error ("read_commented_expression", port, + "no expression after #; comment", SCM_EOL); + scm_ungetc (c, port); + scm_read_expression (port); + return SCM_UNSPECIFIED; +} + static SCM scm_read_extended_symbol (int chr, SCM port) { @@ -1023,6 +1100,12 @@ scm_read_sharp (int chr, SCM port) return (scm_read_extended_symbol (chr, port)); case '!': return (scm_read_scsh_block_comment (chr, port)); + case ';': + return (scm_read_commented_expression (chr, port)); + case '`': + case '\'': + case ',': + return (scm_read_syntax (chr, port)); default: result = scm_read_sharp_extension (chr, port); if (scm_is_eq (result, SCM_UNSPECIFIED)) diff --git a/libguile/stime.c b/libguile/stime.c index 34c8a98fa..5384783e3 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -77,10 +77,6 @@ # include #endif -#if HAVE_CRT_EXTERNS_H -#include /* for Darwin _NSGetEnviron */ -#endif - #ifndef tzname /* For SGI. */ extern char *tzname[]; /* RS6000 and others reject char **tzname. */ #endif @@ -98,15 +94,6 @@ extern char *strptime (); # define timet long #endif -extern char ** environ; - -/* On Apple Darwin in a shared library there's no "environ" to access - directly, instead the address of that variable must be obtained with - _NSGetEnviron(). */ -#if HAVE__NSGETENVIRON && defined (PIC) -#define environ (*_NSGetEnviron()) -#endif - #ifdef HAVE_TIMES static diff --git a/libguile/threads.c b/libguile/threads.c index bb874e230..d63c6197e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1161,6 +1161,16 @@ SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0, 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; + } } } @@ -1491,6 +1501,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, { if (relock) scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner); + t->block_asyncs--; break; } diff --git a/libguile/validate.h b/libguile/validate.h index e05b7dd83..c362c02f3 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -3,7 +3,7 @@ #ifndef SCM_VALIDATE_H #define SCM_VALIDATE_H -/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -150,6 +150,9 @@ cvar = scm_to_bool (flag); \ } while (0) +#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \ + SCM_VALIDATE_SMOB ((_pos), (_obj), bytevector) + #define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character") #define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \ diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h index beecf0fc2..587766a67 100644 --- a/libguile/vm-bootstrap.h +++ b/libguile/vm-bootstrap.h @@ -1,48 +1,24 @@ /* Copyright (C) 2001 Free Software 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 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 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, + * 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 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 General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_VM_BOOTSTRAP_H_ #define _SCM_VM_BOOTSTRAP_H_ -extern void scm_bootstrap_vm (void); +SCM_INTERNAL void scm_bootstrap_vm (void); #endif /* _SCM_VM_BOOTSTRAP_H_ */ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 45251fd70..f43f8c7fe 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ /* This file is included in vm.c multiple times */ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 6bb235401..8c919f630 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ /* This file is included in vm_engine.c */ @@ -147,8 +123,12 @@ #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) +#define ASSERT_BOUND(x) \ + do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \ + } while (0) #else #define CHECK_IP() +#define ASSERT_BOUND(x) #endif /* Get a local copy of the program's "object table" (i.e. the vector of diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h index 7ad2b9da8..02dfbc4d0 100644 --- a/libguile/vm-expand.h +++ b/libguile/vm-expand.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef VM_LABEL #define VM_LABEL(tag) l_##tag diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 4af60265e..38dea32b9 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ /* This file is included in vm_engine.c */ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 5468604d2..42f2b1973 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -230,6 +230,7 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1) VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); + ASSERT_BOUND (*sp); NEXT; } @@ -244,6 +245,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1) } CHECK_EXTERNAL(e); PUSH (SCM_CAR (e)); + ASSERT_BOUND (*sp); NEXT; } @@ -408,12 +410,6 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1) -{ - PUSH (external); - NEXT; -} - /* * branch and jump diff --git a/libguile/vm.c b/libguile/vm.c index 38d085c99..081a691ff 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 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., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 @@ -46,6 +22,7 @@ #include #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "frames.h" #include "instructions.h" diff --git a/libguile/vm.h b/libguile/vm.h index 5c38f9ffa..2f2b617ce 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software 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 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 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, + * 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 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 General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_VM_H_ #define _SCM_VM_H_ @@ -78,37 +54,37 @@ struct scm_vm { SCM trace_frame; /* a frame being traced */ }; -extern SCM scm_the_vm_fluid; +SCM_API SCM scm_the_vm_fluid; #define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x) #define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm)) #define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P) -extern SCM scm_the_vm (); -extern SCM scm_make_vm (void); -extern SCM scm_vm_apply (SCM vm, SCM program, SCM args); -extern SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); -extern SCM scm_vm_option_ref (SCM vm, SCM key); -extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); +SCM_API SCM scm_the_vm (); +SCM_API SCM scm_make_vm (void); +SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args); +SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); +SCM_API SCM scm_vm_option_ref (SCM vm, SCM key); +SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); -extern SCM scm_vm_version (void); -extern SCM scm_the_vm (void); -extern SCM scm_vm_p (SCM obj); -extern SCM scm_vm_ip (SCM vm); -extern SCM scm_vm_sp (SCM vm); -extern SCM scm_vm_fp (SCM vm); -extern SCM scm_vm_boot_hook (SCM vm); -extern SCM scm_vm_halt_hook (SCM vm); -extern SCM scm_vm_next_hook (SCM vm); -extern SCM scm_vm_break_hook (SCM vm); -extern SCM scm_vm_enter_hook (SCM vm); -extern SCM scm_vm_apply_hook (SCM vm); -extern SCM scm_vm_exit_hook (SCM vm); -extern SCM scm_vm_return_hook (SCM vm); -extern SCM scm_vm_option (SCM vm, SCM key); -extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); -extern SCM scm_vm_stats (SCM vm); -extern SCM scm_vm_trace_frame (SCM vm); +SCM_API SCM scm_vm_version (void); +SCM_API SCM scm_the_vm (void); +SCM_API SCM scm_vm_p (SCM obj); +SCM_API SCM scm_vm_ip (SCM vm); +SCM_API SCM scm_vm_sp (SCM vm); +SCM_API SCM scm_vm_fp (SCM vm); +SCM_API SCM scm_vm_boot_hook (SCM vm); +SCM_API SCM scm_vm_halt_hook (SCM vm); +SCM_API SCM scm_vm_next_hook (SCM vm); +SCM_API SCM scm_vm_break_hook (SCM vm); +SCM_API SCM scm_vm_enter_hook (SCM vm); +SCM_API SCM scm_vm_apply_hook (SCM vm); +SCM_API SCM scm_vm_exit_hook (SCM vm); +SCM_API SCM scm_vm_return_hook (SCM vm); +SCM_API SCM scm_vm_option (SCM vm, SCM key); +SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); +SCM_API SCM scm_vm_stats (SCM vm); +SCM_API SCM scm_vm_trace_frame (SCM vm); struct scm_vm_cont { scm_byte_t *ip; @@ -119,16 +95,16 @@ struct scm_vm_cont { scm_t_ptrdiff reloc; }; -extern scm_t_bits scm_tc16_vm_cont; +SCM_API scm_t_bits scm_tc16_vm_cont; #define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) #define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT)) -extern SCM scm_vm_capture_continuations (void); -extern void scm_vm_reinstate_continuations (SCM conts); +SCM_API SCM scm_vm_capture_continuations (void); +SCM_API void scm_vm_reinstate_continuations (SCM conts); -extern SCM scm_load_compiled_with_vm (SCM file); +SCM_API SCM scm_load_compiled_with_vm (SCM file); -extern void scm_init_vm (void); +SCM_INTERNAL void scm_init_vm (void); #endif /* _SCM_VM_H_ */ diff --git a/m4/byteswap.m4 b/m4/byteswap.m4 new file mode 100644 index 000000000..ad13f2286 --- /dev/null +++ b/m4/byteswap.m4 @@ -0,0 +1,18 @@ +# byteswap.m4 serial 3 +dnl Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free 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 Oskar Liljeblad. + +AC_DEFUN([gl_BYTESWAP], +[ + dnl Prerequisites of lib/byteswap.in.h. + AC_CHECK_HEADERS([byteswap.h], [ + BYTESWAP_H='' + ], [ + BYTESWAP_H='byteswap.h' + ]) + AC_SUBST([BYTESWAP_H]) +]) diff --git a/m4/environ.m4 b/m4/environ.m4 new file mode 100644 index 000000000..b17bb60a7 --- /dev/null +++ b/m4/environ.m4 @@ -0,0 +1,36 @@ +# environ.m4 serial 2 +dnl Copyright (C) 2001-2004, 2006-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free 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_ENVIRON], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + dnl Persuade glibc to declare environ. + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + gt_CHECK_VAR_DECL([#include ], environ) + if test $gt_cv_var_environ_declaration != yes; then + HAVE_DECL_ENVIRON=0 + fi +]) + +# Check if a variable is properly declared. +# gt_CHECK_VAR_DECL(includes,variable) +AC_DEFUN([gt_CHECK_VAR_DECL], +[ + define([gt_cv_var], [gt_cv_var_]$2[_declaration]) + AC_MSG_CHECKING([if $2 is properly declared]) + AC_CACHE_VAL([gt_cv_var], [ + AC_TRY_COMPILE([$1 + extern struct { int foo; } $2;], + [$2.foo = 1;], + gt_cv_var=no, + gt_cv_var=yes)]) + AC_MSG_RESULT([$gt_cv_var]) + if test $gt_cv_var = yes; then + AC_DEFINE([HAVE_]translit($2, [a-z], [A-Z])[_DECL], 1, + [Define if you have the declaration of $2.]) + fi + undefine([gt_cv_var]) +]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 1122aa58d..0fbe11969 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,23 +15,30 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write putenv stdlib strcase strftime +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap count-one-bits environ extensions flock fpieee full-read full-write iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) gl_MODULES([ alloca-opt autobuild + byteswap count-one-bits + environ extensions flock fpieee full-read full-write + iconv_open-utf + lib-symbol-visibility + libunistring putenv stdlib strcase strftime + striconveh + string ]) gl_AVOID([]) gl_SOURCE_BASE([lib]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 186f30f7a..8f775107e 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -25,6 +25,7 @@ AC_DEFUN([gl_EARLY], m4_pattern_allow([^gl_LIBOBJS$])dnl a variable m4_pattern_allow([^gl_LTLIBOBJS$])dnl a variable AC_REQUIRE([AC_PROG_RANLIB]) + AC_REQUIRE([AM_PROG_CC_C_O]) AB_INIT AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_REQUIRE([gl_FP_IEEE]) @@ -44,10 +45,19 @@ AC_DEFUN([gl_INIT], gl_COMMON gl_source_base='lib' gl_FUNC_ALLOCA + gl_BYTESWAP gl_COUNT_ONE_BITS + gl_ENVIRON + gl_UNISTD_MODULE_INDICATOR([environ]) gl_FUNC_FLOCK gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) + AM_ICONV + gl_ICONV_H + gl_FUNC_ICONV_OPEN + gl_FUNC_ICONV_OPEN_UTF gl_INLINE + gl_VISIBILITY + gl_LIBUNISTRING gl_LOCALCHARSET LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(top_builddir)/$gl_source_base\"" AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT]) @@ -70,12 +80,21 @@ AC_DEFUN([gl_INIT], gl_STDLIB_H gl_STRCASE gl_FUNC_GNU_STRFTIME + if test $gl_cond_libtool = false; then + gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV" + gl_libdeps="$gl_libdeps $LIBICONV" + fi + gl_HEADER_STRING_H gl_HEADER_STRINGS_H gl_HEADER_SYS_FILE_H AC_PROG_MKDIR_P gl_HEADER_TIME_H gl_TIME_R gl_UNISTD_H + gl_MODULE_INDICATOR([unistr/u8-mbtouc]) + gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) + gl_MODULE_INDICATOR([unistr/u8-mbtoucr]) + gl_MODULE_INDICATOR([unistr/u8-uctomb]) gl_WCHAR_H gl_FUNC_WRITE gl_UNISTD_MODULE_INDICATOR([write]) @@ -207,8 +226,16 @@ AC_DEFUN([gltests_LIBSOURCES], [ # This macro records the list of files which have been installed by # gnulib-tool and may be removed by future gnulib-tool invocations. AC_DEFUN([gl_FILE_LIST], [ + build-aux/config.rpath build-aux/link-warning.h lib/alloca.in.h + lib/byteswap.in.h + lib/c-ctype.c + lib/c-ctype.h + lib/c-strcase.h + lib/c-strcasecmp.c + lib/c-strcaseeq.h + lib/c-strncasecmp.c lib/config.charset lib/count-one-bits.h lib/flock.c @@ -216,6 +243,15 @@ AC_DEFUN([gl_FILE_LIST], [ lib/full-read.h lib/full-write.c lib/full-write.h + lib/iconv.c + lib/iconv.in.h + lib/iconv_close.c + lib/iconv_open-aix.gperf + lib/iconv_open-hpux.gperf + lib/iconv_open-irix.gperf + lib/iconv_open-osf.gperf + lib/iconv_open.c + lib/iconveh.h lib/localcharset.c lib/localcharset.h lib/malloc.c @@ -236,27 +272,49 @@ AC_DEFUN([gl_FILE_LIST], [ lib/streq.h lib/strftime.c lib/strftime.h + lib/striconveh.c + lib/striconveh.h + lib/string.in.h lib/strings.in.h lib/strncasecmp.c lib/sys_file.in.h lib/time.in.h lib/time_r.c lib/unistd.in.h + lib/unistr.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.h lib/verify.h lib/wchar.in.h lib/write.c m4/00gnulib.m4 m4/alloca.m4 m4/autobuild.m4 + m4/byteswap.m4 m4/codeset.m4 m4/count-one-bits.m4 + m4/environ.m4 m4/extensions.m4 m4/flock.m4 m4/fpieee.m4 m4/glibc21.m4 m4/gnulib-common.m4 + m4/iconv.m4 + m4/iconv_h.m4 + m4/iconv_open.m4 m4/include_next.m4 m4/inline.m4 + m4/lib-ld.m4 + m4/lib-link.m4 + m4/lib-prefix.m4 + m4/libunistring.m4 m4/localcharset.m4 m4/locale-fr.m4 m4/locale-ja.m4 @@ -277,12 +335,14 @@ AC_DEFUN([gl_FILE_LIST], [ m4/stdlib_h.m4 m4/strcase.m4 m4/strftime.m4 + m4/string_h.m4 m4/strings_h.m4 m4/sys_file_h.m4 m4/time_h.m4 m4/time_r.m4 m4/tm_gmtoff.m4 m4/unistd_h.m4 + m4/visibility.m4 m4/wchar.m4 m4/wint_t.m4 m4/write.m4 diff --git a/m4/iconv.m4 b/m4/iconv.m4 new file mode 100644 index 000000000..3cc626829 --- /dev/null +++ b/m4/iconv.m4 @@ -0,0 +1,180 @@ +# iconv.m4 serial AM7 (gettext-0.18) +dnl Copyright (C) 2000-2002, 2007-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free 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. + +AC_DEFUN([AM_ICONV_LINKFLAGS_BODY], +[ + dnl Prerequisites of AC_LIB_LINKFLAGS_BODY. + AC_REQUIRE([AC_LIB_PREPARE_PREFIX]) + AC_REQUIRE([AC_LIB_RPATH]) + + dnl Search for libiconv and define LIBICONV, LTLIBICONV and INCICONV + dnl accordingly. + AC_LIB_LINKFLAGS_BODY([iconv]) +]) + +AC_DEFUN([AM_ICONV_LINK], +[ + dnl Some systems have iconv in libc, some have it in libiconv (OSF/1 and + dnl those with the standalone portable GNU libiconv installed). + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + + dnl Search for libiconv and define LIBICONV, LTLIBICONV and INCICONV + dnl accordingly. + AC_REQUIRE([AM_ICONV_LINKFLAGS_BODY]) + + dnl Add $INCICONV to CPPFLAGS before performing the following checks, + dnl because if the user has installed libiconv and not disabled its use + dnl via --without-libiconv-prefix, he wants to use it. The first + dnl AC_TRY_LINK will then fail, the second AC_TRY_LINK will succeed. + am_save_CPPFLAGS="$CPPFLAGS" + AC_LIB_APPENDTOVAR([CPPFLAGS], [$INCICONV]) + + AC_CACHE_CHECK([for iconv], [am_cv_func_iconv], [ + am_cv_func_iconv="no, consider installing GNU libiconv" + am_cv_lib_iconv=no + AC_TRY_LINK([#include +#include ], + [iconv_t cd = iconv_open("",""); + iconv(cd,NULL,NULL,NULL,NULL); + iconv_close(cd);], + [am_cv_func_iconv=yes]) + if test "$am_cv_func_iconv" != yes; then + am_save_LIBS="$LIBS" + LIBS="$LIBS $LIBICONV" + AC_TRY_LINK([#include +#include ], + [iconv_t cd = iconv_open("",""); + iconv(cd,NULL,NULL,NULL,NULL); + iconv_close(cd);], + [am_cv_lib_iconv=yes] + [am_cv_func_iconv=yes]) + LIBS="$am_save_LIBS" + fi + ]) + if test "$am_cv_func_iconv" = yes; then + AC_CACHE_CHECK([for working iconv], [am_cv_func_iconv_works], [ + dnl This tests against bugs in AIX 5.1 and HP-UX 11.11. + am_save_LIBS="$LIBS" + if test $am_cv_lib_iconv = yes; then + LIBS="$LIBS $LIBICONV" + fi + AC_TRY_RUN([ +#include +#include +int main () +{ + /* 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 */ + char buf[10]; + 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, + &outptr, &outbytesleft); + if (res == 0) + return 1; + } + } +#if 0 /* This bug could be worked around by the caller. */ + /* Test against HP-UX 11.11 bug: Positive return value instead of 0. */ + { + 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"; + char buf[50]; + 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, + &outptr, &outbytesleft); + if ((int)res > 0) + return 1; + } + } +#endif + /* Test against HP-UX 11.11 bug: No converter from EUC-JP to UTF-8 is + provided. */ + if (/* Try standardized names. */ + iconv_open ("UTF-8", "EUC-JP") == (iconv_t)(-1) + /* Try IRIX, OSF/1 names. */ + && iconv_open ("UTF-8", "eucJP") == (iconv_t)(-1) + /* Try AIX names. */ + && iconv_open ("UTF-8", "IBM-eucJP") == (iconv_t)(-1) + /* Try HP-UX names. */ + && iconv_open ("utf8", "eucJP") == (iconv_t)(-1)) + return 1; + return 0; +}], [am_cv_func_iconv_works=yes], [am_cv_func_iconv_works=no], + [case "$host_os" in + aix* | hpux*) am_cv_func_iconv_works="guessing no" ;; + *) am_cv_func_iconv_works="guessing yes" ;; + esac]) + LIBS="$am_save_LIBS" + ]) + case "$am_cv_func_iconv_works" in + *no) am_func_iconv=no am_cv_lib_iconv=no ;; + *) am_func_iconv=yes ;; + esac + else + am_func_iconv=no am_cv_lib_iconv=no + fi + if test "$am_func_iconv" = yes; then + AC_DEFINE([HAVE_ICONV], [1], + [Define if you have the iconv() function and it works.]) + fi + if test "$am_cv_lib_iconv" = yes; then + AC_MSG_CHECKING([how to link with libiconv]) + AC_MSG_RESULT([$LIBICONV]) + else + dnl If $LIBICONV didn't lead to a usable library, we don't need $INCICONV + dnl either. + CPPFLAGS="$am_save_CPPFLAGS" + LIBICONV= + LTLIBICONV= + fi + AC_SUBST([LIBICONV]) + AC_SUBST([LTLIBICONV]) +]) + +AC_DEFUN([AM_ICONV], +[ + AM_ICONV_LINK + if test "$am_cv_func_iconv" = yes; then + AC_MSG_CHECKING([for iconv declaration]) + AC_CACHE_VAL([am_cv_proto_iconv], [ + AC_TRY_COMPILE([ +#include +#include +extern +#ifdef __cplusplus +"C" +#endif +#if defined(__STDC__) || defined(__cplusplus) +size_t iconv (iconv_t cd, char * *inbuf, size_t *inbytesleft, char * *outbuf, size_t *outbytesleft); +#else +size_t iconv(); +#endif +], [], [am_cv_proto_iconv_arg1=""], [am_cv_proto_iconv_arg1="const"]) + am_cv_proto_iconv="extern size_t iconv (iconv_t cd, $am_cv_proto_iconv_arg1 char * *inbuf, size_t *inbytesleft, char * *outbuf, size_t *outbytesleft);"]) + am_cv_proto_iconv=`echo "[$]am_cv_proto_iconv" | tr -s ' ' | sed -e 's/( /(/'` + AC_MSG_RESULT([${ac_t:- + }$am_cv_proto_iconv]) + AC_DEFINE_UNQUOTED([ICONV_CONST], [$am_cv_proto_iconv_arg1], + [Define as const if the declaration of iconv() needs const.]) + fi +]) diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4 new file mode 100644 index 000000000..bc05b0551 --- /dev/null +++ b/m4/iconv_h.m4 @@ -0,0 +1,34 @@ +# iconv_h.m4 serial 4 +dnl Copyright (C) 2007-2008 Free Software Foundation, Inc. +dnl This file is free software; the Free 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_ICONV_H], +[ + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + gl_CHECK_NEXT_HEADERS([iconv.h]) +]) + +dnl Unconditionally enables the replacement of . +AC_DEFUN([gl_REPLACE_ICONV_H], +[ + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + ICONV_H='iconv.h' +]) + +AC_DEFUN([gl_ICONV_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1 +]) + +AC_DEFUN([gl_ICONV_H_DEFAULTS], +[ + dnl Assume proper GNU behavior unless another module says otherwise. + REPLACE_ICONV=0; AC_SUBST([REPLACE_ICONV]) + REPLACE_ICONV_OPEN=0; AC_SUBST([REPLACE_ICONV_OPEN]) + REPLACE_ICONV_UTF=0; AC_SUBST([REPLACE_ICONV_UTF]) + ICONV_H=''; AC_SUBST([ICONV_H]) +]) diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4 new file mode 100644 index 000000000..c7b948e90 --- /dev/null +++ b/m4/iconv_open.m4 @@ -0,0 +1,237 @@ +# iconv_open.m4 serial 5 +dnl Copyright (C) 2007-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free 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_ICONV_OPEN], +[ + AC_REQUIRE([AM_ICONV]) + AC_REQUIRE([AC_CANONICAL_HOST]) + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + if test "$am_cv_func_iconv" = yes; then + dnl Test whether iconv_open accepts standardized encoding names. + dnl We know that GNU libiconv and GNU libc do. + AC_EGREP_CPP([gnu_iconv], [ + #include + #if defined _LIBICONV_VERSION || defined __GLIBC__ + gnu_iconv + #endif + ], [gl_func_iconv_gnu=yes], [gl_func_iconv_gnu=no]) + if test $gl_func_iconv_gnu = no; then + iconv_flavor= + case "$host_os" in + aix*) iconv_flavor=ICONV_FLAVOR_AIX ;; + irix*) iconv_flavor=ICONV_FLAVOR_IRIX ;; + hpux*) iconv_flavor=ICONV_FLAVOR_HPUX ;; + osf*) iconv_flavor=ICONV_FLAVOR_OSF ;; + esac + if test -n "$iconv_flavor"; then + AC_DEFINE_UNQUOTED([ICONV_FLAVOR], [$iconv_flavor], + [Define to a symbolic name denoting the flavor of iconv_open() + implementation.]) + gl_REPLACE_ICONV_OPEN + fi + fi + fi +]) + +AC_DEFUN([gl_REPLACE_ICONV_OPEN], +[ + gl_REPLACE_ICONV_H + REPLACE_ICONV_OPEN=1 + AC_LIBOBJ([iconv_open]) +]) + +AC_DEFUN([gl_FUNC_ICONV_OPEN_UTF], +[ + AC_REQUIRE([gl_FUNC_ICONV_OPEN]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + if test "$am_cv_func_iconv" = yes; then + if test -n "$am_cv_proto_iconv_arg1"; then + ICONV_CONST="const" + else + ICONV_CONST= + fi + AC_SUBST([ICONV_CONST]) + AC_CACHE_CHECK([whether iconv supports conversion between UTF-8 and UTF-{16,32}{BE,LE}], + [gl_cv_func_iconv_supports_utf], + [ + save_LIBS="$LIBS" + LIBS="$LIBS $LIBICONV" + AC_TRY_RUN([ +#include +#include +#include +#include +#include +#define ASSERT(expr) if (!(expr)) return 1; +int main () +{ + /* Test conversion from UTF-8 to UTF-16BE with no errors. */ + { + static const char input[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + static const char expected[] = + "\000J\000a\000p\000a\000n\000e\000s\000e\000 \000(\145\345\147\054\212\236\000)\000 \000[\330\065\335\015\330\065\335\036\330\065\335\055\000]"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-16BE", "UTF-8"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + /* Test conversion from UTF-8 to UTF-16LE with no errors. */ + { + static const char input[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + static const char expected[] = + "J\000a\000p\000a\000n\000e\000s\000e\000 \000(\000\345\145\054\147\236\212)\000 \000[\000\065\330\015\335\065\330\036\335\065\330\055\335]\000"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-16LE", "UTF-8"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + /* Test conversion from UTF-8 to UTF-32BE with no errors. */ + { + static const char input[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + static const char expected[] = + "\000\000\000J\000\000\000a\000\000\000p\000\000\000a\000\000\000n\000\000\000e\000\000\000s\000\000\000e\000\000\000 \000\000\000(\000\000\145\345\000\000\147\054\000\000\212\236\000\000\000)\000\000\000 \000\000\000[\000\001\325\015\000\001\325\036\000\001\325\055\000\000\000]"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-32BE", "UTF-8"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + /* Test conversion from UTF-8 to UTF-32LE with no errors. */ + { + static const char input[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + static const char expected[] = + "J\000\000\000a\000\000\000p\000\000\000a\000\000\000n\000\000\000e\000\000\000s\000\000\000e\000\000\000 \000\000\000(\000\000\000\345\145\000\000\054\147\000\000\236\212\000\000)\000\000\000 \000\000\000[\000\000\000\015\325\001\000\036\325\001\000\055\325\001\000]\000\000\000"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-32LE", "UTF-8"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + /* Test conversion from UTF-16BE to UTF-8 with no errors. + This test fails on NetBSD 3.0. */ + { + static const char input[] = + "\000J\000a\000p\000a\000n\000e\000s\000e\000 \000(\145\345\147\054\212\236\000)\000 \000[\330\065\335\015\330\065\335\036\330\065\335\055\000]"; + static const char expected[] = + "Japanese (\346\227\245\346\234\254\350\252\236) [\360\235\224\215\360\235\224\236\360\235\224\255]"; + iconv_t cd; + char buf[100]; + const char *inptr; + size_t inbytesleft; + char *outptr; + size_t outbytesleft; + size_t res; + cd = iconv_open ("UTF-8", "UTF-16BE"); + ASSERT (cd != (iconv_t)(-1)); + inptr = input; + inbytesleft = sizeof (input) - 1; + outptr = buf; + outbytesleft = sizeof (buf); + res = iconv (cd, + (ICONV_CONST char **) &inptr, &inbytesleft, + &outptr, &outbytesleft); + ASSERT (res == 0 && inbytesleft == 0); + ASSERT (outptr == buf + (sizeof (expected) - 1)); + ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0); + ASSERT (iconv_close (cd) == 0); + } + return 0; +}], [gl_cv_func_iconv_supports_utf=yes], [gl_cv_func_iconv_supports_utf=no], + [ + dnl We know that GNU libiconv, GNU libc, and Solaris >= 9 do. + dnl OSF/1 5.1 has these encodings, but inserts a BOM in the "to" + dnl direction. + gl_cv_func_iconv_supports_utf=no + if test $gl_func_iconv_gnu = yes; then + gl_cv_func_iconv_supports_utf=yes + else +changequote(,)dnl + case "$host_os" in + solaris2.9 | solaris2.1[0-9]) gl_cv_func_iconv_supports_utf=yes ;; + esac +changequote([,])dnl + fi + ]) + LIBS="$save_LIBS" + ]) + if test $gl_cv_func_iconv_supports_utf = no; then + REPLACE_ICONV_UTF=1 + AC_DEFINE([REPLACE_ICONV_UTF], [1], + [Define if the iconv() functions are enhanced to handle the UTF-{16,32}{BE,LE} encodings.]) + REPLACE_ICONV=1 + gl_REPLACE_ICONV_OPEN + AC_LIBOBJ([iconv]) + AC_LIBOBJ([iconv_close]) + fi + fi +]) diff --git a/m4/include_next.m4 b/m4/include_next.m4 index d6101fe32..5e22ded93 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -1,4 +1,4 @@ -# include_next.m4 serial 12 +# include_next.m4 serial 14 dnl Copyright (C) 2006-2009 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -104,8 +104,14 @@ EOF # For each arg foo.h, if #include_next works, define NEXT_FOO_H to be # ''; otherwise define it to be # '"///usr/include/foo.h"', or whatever other absolute file name is suitable. +# Also, if #include_next works as first preprocessing directive in a file, +# define NEXT_AS_FIRST_DIRECTIVE_FOO_H to be ''; otherwise define it to +# be +# '"///usr/include/foo.h"', or whatever other absolute file name is suitable. # That way, a header file with the following line: # #@INCLUDE_NEXT@ @NEXT_FOO_H@ +# or +# #@INCLUDE_NEXT_AS_FIRST_DIRECTIVE@ @NEXT_AS_FIRST_DIRECTIVE_FOO_H@ # behaves (after sed substitution) as if it contained # #include_next # even if the compiler does not support include_next. @@ -123,15 +129,15 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS], m4_foreach_w([gl_HEADER_NAME], [$1], [AS_VAR_PUSHDEF([gl_next_header], - [gl_cv_next_]m4_quote(m4_defn([gl_HEADER_NAME]))) + [gl_cv_next_]m4_defn([gl_HEADER_NAME])) if test $gl_cv_have_include_next = yes; then AS_VAR_SET([gl_next_header], ['<'gl_HEADER_NAME'>']) else AC_CACHE_CHECK( - [absolute name of <]m4_quote(m4_defn([gl_HEADER_NAME]))[>], - m4_quote(m4_defn([gl_next_header])), + [absolute name of <]m4_defn([gl_HEADER_NAME])[>], + m4_defn([gl_next_header]), [AS_VAR_PUSHDEF([gl_header_exists], - [ac_cv_header_]m4_quote(m4_defn([gl_HEADER_NAME]))) + [ac_cv_header_]m4_defn([gl_HEADER_NAME])) if test AS_VAR_GET(gl_header_exists) = yes; then AC_LANG_CONFTEST( [AC_LANG_SOURCE( @@ -153,8 +159,8 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS], dnl so use subshell. AS_VAR_SET([gl_next_header], ['"'`(eval "$gl_absname_cpp conftest.$ac_ext") 2>&AS_MESSAGE_LOG_FD | - sed -n '\#/]m4_quote(m4_defn([gl_HEADER_NAME]))[#{ - s#.*"\(.*/]m4_quote(m4_defn([gl_HEADER_NAME]))[\)".*#\1# + sed -n '\#/]m4_defn([gl_HEADER_NAME])[#{ + s#.*"\(.*/]m4_defn([gl_HEADER_NAME])[\)".*#\1# s#^/[^/]#//&# p q @@ -165,7 +171,17 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS], AS_VAR_POPDEF([gl_header_exists])]) fi AC_SUBST( - AS_TR_CPP([NEXT_]m4_quote(m4_defn([gl_HEADER_NAME]))), + AS_TR_CPP([NEXT_]m4_defn([gl_HEADER_NAME])), [AS_VAR_GET([gl_next_header])]) + if test $gl_cv_have_include_next = yes || test $gl_cv_have_include_next = buggy; then + # INCLUDE_NEXT_AS_FIRST_DIRECTIVE='include_next' + gl_next_as_first_directive='<'gl_HEADER_NAME'>' + else + # INCLUDE_NEXT_AS_FIRST_DIRECTIVE='include' + gl_next_as_first_directive=AS_VAR_GET([gl_next_header]) + fi + AC_SUBST( + AS_TR_CPP([NEXT_AS_FIRST_DIRECTIVE_]m4_defn([gl_HEADER_NAME])), + [$gl_next_as_first_directive]) AS_VAR_POPDEF([gl_next_header])]) ]) diff --git a/m4/lib-ld.m4 b/m4/lib-ld.m4 new file mode 100644 index 000000000..e4863f2c9 --- /dev/null +++ b/m4/lib-ld.m4 @@ -0,0 +1,110 @@ +# lib-ld.m4 serial 4 (gettext-0.18) +dnl Copyright (C) 1996-2003, 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free 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 Subroutines of libtool.m4, +dnl with replacements s/AC_/AC_LIB/ and s/lt_cv/acl_cv/ to avoid collision +dnl with libtool.m4. + +dnl From libtool-1.4. Sets the variable with_gnu_ld to yes or no. +AC_DEFUN([AC_LIB_PROG_LD_GNU], +[AC_CACHE_CHECK([if the linker ($LD) is GNU ld], [acl_cv_prog_gnu_ld], +[# I'd rather use --version here, but apparently some GNU ld's only accept -v. +case `$LD -v 2>&1 conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi +ac_prog=ld +if test "$GCC" = yes; then + # Check if gcc -print-prog-name=ld gives a path. + AC_MSG_CHECKING([for ld used by GCC]) + case $host in + *-*-mingw*) + # gcc leaves a trailing carriage return which upsets mingw + ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;; + *) + ac_prog=`($CC -print-prog-name=ld) 2>&5` ;; + esac + case $ac_prog in + # Accept absolute paths. + [[\\/]* | [A-Za-z]:[\\/]*)] + [re_direlt='/[^/][^/]*/\.\./'] + # Canonicalize the path of ld + ac_prog=`echo $ac_prog| sed 's%\\\\%/%g'` + while echo $ac_prog | grep "$re_direlt" > /dev/null 2>&1; do + ac_prog=`echo $ac_prog| sed "s%$re_direlt%/%"` + done + test -z "$LD" && LD="$ac_prog" + ;; + "") + # If it fails, then pretend we aren't using GCC. + ac_prog=ld + ;; + *) + # If it is relative, then search for the first ld in PATH. + with_gnu_ld=unknown + ;; + esac +elif test "$with_gnu_ld" = yes; then + AC_MSG_CHECKING([for GNU ld]) +else + AC_MSG_CHECKING([for non-GNU ld]) +fi +AC_CACHE_VAL([acl_cv_path_LD], +[if test -z "$LD"; then + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}${PATH_SEPARATOR-:}" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then + acl_cv_path_LD="$ac_dir/$ac_prog" + # Check to see if the program is GNU ld. I'd rather use --version, + # but apparently some GNU ld's only accept -v. + # Break only if it was the GNU/non-GNU ld that we prefer. + case `"$acl_cv_path_LD" -v 2>&1 < /dev/null` in + *GNU* | *'with BFD'*) + test "$with_gnu_ld" != no && break ;; + *) + test "$with_gnu_ld" != yes && break ;; + esac + fi + done + IFS="$ac_save_ifs" +else + acl_cv_path_LD="$LD" # Let the user override the test with a path. +fi]) +LD="$acl_cv_path_LD" +if test -n "$LD"; then + AC_MSG_RESULT([$LD]) +else + AC_MSG_RESULT([no]) +fi +test -z "$LD" && AC_MSG_ERROR([no acceptable ld found in \$PATH]) +AC_LIB_PROG_LD_GNU +]) diff --git a/m4/lib-link.m4 b/m4/lib-link.m4 new file mode 100644 index 000000000..21442033c --- /dev/null +++ b/m4/lib-link.m4 @@ -0,0 +1,761 @@ +# lib-link.m4 serial 19 (gettext-0.18) +dnl Copyright (C) 2001-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free 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. + +AC_PREREQ([2.54]) + +dnl AC_LIB_LINKFLAGS(name [, dependencies]) searches for libname and +dnl the libraries corresponding to explicit and implicit dependencies. +dnl Sets and AC_SUBSTs the LIB${NAME} and LTLIB${NAME} variables and +dnl augments the CPPFLAGS variable. +dnl Sets and AC_SUBSTs the LIB${NAME}_PREFIX variable to nonempty if libname +dnl was found in ${LIB${NAME}_PREFIX}/$acl_libdirstem. +AC_DEFUN([AC_LIB_LINKFLAGS], +[ + AC_REQUIRE([AC_LIB_PREPARE_PREFIX]) + AC_REQUIRE([AC_LIB_RPATH]) + pushdef([Name],[translit([$1],[./-], [___])]) + pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + AC_CACHE_CHECK([how to link with lib[]$1], [ac_cv_lib[]Name[]_libs], [ + AC_LIB_LINKFLAGS_BODY([$1], [$2]) + ac_cv_lib[]Name[]_libs="$LIB[]NAME" + ac_cv_lib[]Name[]_ltlibs="$LTLIB[]NAME" + ac_cv_lib[]Name[]_cppflags="$INC[]NAME" + ac_cv_lib[]Name[]_prefix="$LIB[]NAME[]_PREFIX" + ]) + LIB[]NAME="$ac_cv_lib[]Name[]_libs" + LTLIB[]NAME="$ac_cv_lib[]Name[]_ltlibs" + INC[]NAME="$ac_cv_lib[]Name[]_cppflags" + LIB[]NAME[]_PREFIX="$ac_cv_lib[]Name[]_prefix" + AC_LIB_APPENDTOVAR([CPPFLAGS], [$INC]NAME) + AC_SUBST([LIB]NAME) + AC_SUBST([LTLIB]NAME) + AC_SUBST([LIB]NAME[_PREFIX]) + dnl Also set HAVE_LIB[]NAME so that AC_LIB_HAVE_LINKFLAGS can reuse the + dnl results of this search when this library appears as a dependency. + HAVE_LIB[]NAME=yes + popdef([NAME]) + popdef([Name]) +]) + +dnl AC_LIB_HAVE_LINKFLAGS(name, dependencies, includes, testcode, [missing-message]) +dnl searches for libname and the libraries corresponding to explicit and +dnl implicit dependencies, together with the specified include files and +dnl the ability to compile and link the specified testcode. The missing-message +dnl defaults to 'no' and may contain additional hints for the user. +dnl If found, it sets and AC_SUBSTs HAVE_LIB${NAME}=yes and the LIB${NAME} +dnl and LTLIB${NAME} variables and augments the CPPFLAGS variable, and +dnl #defines HAVE_LIB${NAME} to 1. Otherwise, it sets and AC_SUBSTs +dnl HAVE_LIB${NAME}=no and LIB${NAME} and LTLIB${NAME} to empty. +dnl Sets and AC_SUBSTs the LIB${NAME}_PREFIX variable to nonempty if libname +dnl was found in ${LIB${NAME}_PREFIX}/$acl_libdirstem. +AC_DEFUN([AC_LIB_HAVE_LINKFLAGS], +[ + AC_REQUIRE([AC_LIB_PREPARE_PREFIX]) + AC_REQUIRE([AC_LIB_RPATH]) + pushdef([Name],[translit([$1],[./-], [___])]) + pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + + dnl Search for lib[]Name and define LIB[]NAME, LTLIB[]NAME and INC[]NAME + dnl accordingly. + AC_LIB_LINKFLAGS_BODY([$1], [$2]) + + dnl Add $INC[]NAME to CPPFLAGS before performing the following checks, + dnl because if the user has installed lib[]Name and not disabled its use + dnl via --without-lib[]Name-prefix, he wants to use it. + ac_save_CPPFLAGS="$CPPFLAGS" + AC_LIB_APPENDTOVAR([CPPFLAGS], [$INC]NAME) + + AC_CACHE_CHECK([for lib[]$1], [ac_cv_lib[]Name], [ + ac_save_LIBS="$LIBS" + LIBS="$LIBS $LIB[]NAME" + AC_TRY_LINK([$3], [$4], + [ac_cv_lib[]Name=yes], + [ac_cv_lib[]Name='m4_if([$5], [], [no], [[$5]])']) + LIBS="$ac_save_LIBS" + ]) + if test "$ac_cv_lib[]Name" = yes; then + HAVE_LIB[]NAME=yes + AC_DEFINE([HAVE_LIB]NAME, 1, [Define if you have the lib[]$1 library.]) + AC_MSG_CHECKING([how to link with lib[]$1]) + AC_MSG_RESULT([$LIB[]NAME]) + else + HAVE_LIB[]NAME=no + dnl If $LIB[]NAME didn't lead to a usable library, we don't need + dnl $INC[]NAME either. + CPPFLAGS="$ac_save_CPPFLAGS" + LIB[]NAME= + LTLIB[]NAME= + LIB[]NAME[]_PREFIX= + fi + AC_SUBST([HAVE_LIB]NAME) + AC_SUBST([LIB]NAME) + AC_SUBST([LTLIB]NAME) + AC_SUBST([LIB]NAME[_PREFIX]) + popdef([NAME]) + popdef([Name]) +]) + +dnl Determine the platform dependent parameters needed to use rpath: +dnl acl_libext, +dnl acl_shlibext, +dnl acl_hardcode_libdir_flag_spec, +dnl acl_hardcode_libdir_separator, +dnl acl_hardcode_direct, +dnl acl_hardcode_minus_L. +AC_DEFUN([AC_LIB_RPATH], +[ + dnl Tell automake >= 1.10 to complain if config.rpath is missing. + m4_ifdef([AC_REQUIRE_AUX_FILE], [AC_REQUIRE_AUX_FILE([config.rpath])]) + AC_REQUIRE([AC_PROG_CC]) dnl we use $CC, $GCC, $LDFLAGS + AC_REQUIRE([AC_LIB_PROG_LD]) dnl we use $LD, $with_gnu_ld + AC_REQUIRE([AC_CANONICAL_HOST]) dnl we use $host + AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT]) dnl we use $ac_aux_dir + AC_CACHE_CHECK([for shared library run path origin], [acl_cv_rpath], [ + CC="$CC" GCC="$GCC" LDFLAGS="$LDFLAGS" LD="$LD" with_gnu_ld="$with_gnu_ld" \ + ${CONFIG_SHELL-/bin/sh} "$ac_aux_dir/config.rpath" "$host" > conftest.sh + . ./conftest.sh + rm -f ./conftest.sh + acl_cv_rpath=done + ]) + wl="$acl_cv_wl" + acl_libext="$acl_cv_libext" + acl_shlibext="$acl_cv_shlibext" + acl_libname_spec="$acl_cv_libname_spec" + acl_library_names_spec="$acl_cv_library_names_spec" + acl_hardcode_libdir_flag_spec="$acl_cv_hardcode_libdir_flag_spec" + acl_hardcode_libdir_separator="$acl_cv_hardcode_libdir_separator" + acl_hardcode_direct="$acl_cv_hardcode_direct" + acl_hardcode_minus_L="$acl_cv_hardcode_minus_L" + dnl Determine whether the user wants rpath handling at all. + AC_ARG_ENABLE([rpath], + [ --disable-rpath do not hardcode runtime library paths], + :, enable_rpath=yes) +]) + +dnl AC_LIB_FROMPACKAGE(name, package) +dnl declares that libname comes from the given package. The configure file +dnl will then not have a --with-libname-prefix option but a +dnl --with-package-prefix option. Several libraries can come from the same +dnl package. This declaration must occur before an AC_LIB_LINKFLAGS or similar +dnl macro call that searches for libname. +AC_DEFUN([AC_LIB_FROMPACKAGE], +[ + pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + define([acl_frompackage_]NAME, [$2]) + popdef([NAME]) + pushdef([PACK],[$2]) + pushdef([PACKUP],[translit(PACK,[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + define([acl_libsinpackage_]PACKUP, + m4_ifdef([acl_libsinpackage_]PACKUP, [acl_libsinpackage_]PACKUP[[, ]],)[lib$1]) + popdef([PACKUP]) + popdef([PACK]) +]) + +dnl AC_LIB_LINKFLAGS_BODY(name [, dependencies]) searches for libname and +dnl the libraries corresponding to explicit and implicit dependencies. +dnl Sets the LIB${NAME}, LTLIB${NAME} and INC${NAME} variables. +dnl Also, sets the LIB${NAME}_PREFIX variable to nonempty if libname was found +dnl in ${LIB${NAME}_PREFIX}/$acl_libdirstem. +AC_DEFUN([AC_LIB_LINKFLAGS_BODY], +[ + AC_REQUIRE([AC_LIB_PREPARE_MULTILIB]) + pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + pushdef([PACK],[m4_ifdef([acl_frompackage_]NAME, [acl_frompackage_]NAME, lib[$1])]) + pushdef([PACKUP],[translit(PACK,[abcdefghijklmnopqrstuvwxyz./-], + [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])]) + pushdef([PACKLIBS],[m4_ifdef([acl_frompackage_]NAME, [acl_libsinpackage_]PACKUP, lib[$1])]) + dnl Autoconf >= 2.61 supports dots in --with options. + pushdef([P_A_C_K],[m4_if(m4_version_compare(m4_defn([m4_PACKAGE_VERSION]),[2.61]),[-1],[translit(PACK,[.],[_])],PACK)]) + dnl By default, look in $includedir and $libdir. + use_additional=yes + AC_LIB_WITH_FINAL_PREFIX([ + eval additional_includedir=\"$includedir\" + eval additional_libdir=\"$libdir\" + ]) + AC_ARG_WITH(P_A_C_K[-prefix], +[[ --with-]]P_A_C_K[[-prefix[=DIR] search for ]PACKLIBS[ in DIR/include and DIR/lib + --without-]]P_A_C_K[[-prefix don't search for ]PACKLIBS[ in includedir and libdir]], +[ + if test "X$withval" = "Xno"; then + use_additional=no + else + if test "X$withval" = "X"; then + AC_LIB_WITH_FINAL_PREFIX([ + eval additional_includedir=\"$includedir\" + eval additional_libdir=\"$libdir\" + ]) + else + additional_includedir="$withval/include" + additional_libdir="$withval/$acl_libdirstem" + if test "$acl_libdirstem2" != "$acl_libdirstem" \ + && ! test -d "$withval/$acl_libdirstem"; then + additional_libdir="$withval/$acl_libdirstem2" + fi + fi + fi +]) + dnl Search the library and its dependencies in $additional_libdir and + dnl $LDFLAGS. Using breadth-first-seach. + LIB[]NAME= + LTLIB[]NAME= + INC[]NAME= + LIB[]NAME[]_PREFIX= + rpathdirs= + ltrpathdirs= + names_already_handled= + names_next_round='$1 $2' + while test -n "$names_next_round"; do + names_this_round="$names_next_round" + names_next_round= + for name in $names_this_round; do + already_handled= + for n in $names_already_handled; do + if test "$n" = "$name"; then + already_handled=yes + break + fi + done + if test -z "$already_handled"; then + names_already_handled="$names_already_handled $name" + dnl See if it was already located by an earlier AC_LIB_LINKFLAGS + dnl or AC_LIB_HAVE_LINKFLAGS call. + uppername=`echo "$name" | sed -e 'y|abcdefghijklmnopqrstuvwxyz./-|ABCDEFGHIJKLMNOPQRSTUVWXYZ___|'` + eval value=\"\$HAVE_LIB$uppername\" + if test -n "$value"; then + if test "$value" = yes; then + eval value=\"\$LIB$uppername\" + test -z "$value" || LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$value" + eval value=\"\$LTLIB$uppername\" + test -z "$value" || LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }$value" + else + dnl An earlier call to AC_LIB_HAVE_LINKFLAGS has determined + dnl that this library doesn't exist. So just drop it. + : + fi + else + dnl Search the library lib$name in $additional_libdir and $LDFLAGS + dnl and the already constructed $LIBNAME/$LTLIBNAME. + found_dir= + found_la= + found_so= + found_a= + eval libname=\"$acl_libname_spec\" # typically: libname=lib$name + if test -n "$acl_shlibext"; then + shrext=".$acl_shlibext" # typically: shrext=.so + else + shrext= + fi + if test $use_additional = yes; then + dir="$additional_libdir" + dnl The same code as in the loop below: + dnl First look for a shared library. + if test -n "$acl_shlibext"; then + if test -f "$dir/$libname$shrext"; then + found_dir="$dir" + found_so="$dir/$libname$shrext" + else + if test "$acl_library_names_spec" = '$libname$shrext$versuffix'; then + ver=`(cd "$dir" && \ + for f in "$libname$shrext".*; do echo "$f"; done \ + | sed -e "s,^$libname$shrext\\\\.,," \ + | sort -t '.' -n -r -k1,1 -k2,2 -k3,3 -k4,4 -k5,5 \ + | sed 1q ) 2>/dev/null` + if test -n "$ver" && test -f "$dir/$libname$shrext.$ver"; then + found_dir="$dir" + found_so="$dir/$libname$shrext.$ver" + fi + else + eval library_names=\"$acl_library_names_spec\" + for f in $library_names; do + if test -f "$dir/$f"; then + found_dir="$dir" + found_so="$dir/$f" + break + fi + done + fi + fi + fi + dnl Then look for a static library. + if test "X$found_dir" = "X"; then + if test -f "$dir/$libname.$acl_libext"; then + found_dir="$dir" + found_a="$dir/$libname.$acl_libext" + fi + fi + if test "X$found_dir" != "X"; then + if test -f "$dir/$libname.la"; then + found_la="$dir/$libname.la" + fi + fi + fi + if test "X$found_dir" = "X"; then + for x in $LDFLAGS $LTLIB[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + case "$x" in + -L*) + dir=`echo "X$x" | sed -e 's/^X-L//'` + dnl First look for a shared library. + if test -n "$acl_shlibext"; then + if test -f "$dir/$libname$shrext"; then + found_dir="$dir" + found_so="$dir/$libname$shrext" + else + if test "$acl_library_names_spec" = '$libname$shrext$versuffix'; then + ver=`(cd "$dir" && \ + for f in "$libname$shrext".*; do echo "$f"; done \ + | sed -e "s,^$libname$shrext\\\\.,," \ + | sort -t '.' -n -r -k1,1 -k2,2 -k3,3 -k4,4 -k5,5 \ + | sed 1q ) 2>/dev/null` + if test -n "$ver" && test -f "$dir/$libname$shrext.$ver"; then + found_dir="$dir" + found_so="$dir/$libname$shrext.$ver" + fi + else + eval library_names=\"$acl_library_names_spec\" + for f in $library_names; do + if test -f "$dir/$f"; then + found_dir="$dir" + found_so="$dir/$f" + break + fi + done + fi + fi + fi + dnl Then look for a static library. + if test "X$found_dir" = "X"; then + if test -f "$dir/$libname.$acl_libext"; then + found_dir="$dir" + found_a="$dir/$libname.$acl_libext" + fi + fi + if test "X$found_dir" != "X"; then + if test -f "$dir/$libname.la"; then + found_la="$dir/$libname.la" + fi + fi + ;; + esac + if test "X$found_dir" != "X"; then + break + fi + done + fi + if test "X$found_dir" != "X"; then + dnl Found the library. + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-L$found_dir -l$name" + if test "X$found_so" != "X"; then + dnl Linking with a shared library. We attempt to hardcode its + dnl directory into the executable's runpath, unless it's the + dnl standard /usr/lib. + if test "$enable_rpath" = no \ + || test "X$found_dir" = "X/usr/$acl_libdirstem" \ + || test "X$found_dir" = "X/usr/$acl_libdirstem2"; then + dnl No hardcoding is needed. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so" + else + dnl Use an explicit option to hardcode DIR into the resulting + dnl binary. + dnl Potentially add DIR to ltrpathdirs. + dnl The ltrpathdirs will be appended to $LTLIBNAME at the end. + haveit= + for x in $ltrpathdirs; do + if test "X$x" = "X$found_dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + ltrpathdirs="$ltrpathdirs $found_dir" + fi + dnl The hardcoding into $LIBNAME is system dependent. + if test "$acl_hardcode_direct" = yes; then + dnl Using DIR/libNAME.so during linking hardcodes DIR into the + dnl resulting binary. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so" + else + if test -n "$acl_hardcode_libdir_flag_spec" && test "$acl_hardcode_minus_L" = no; then + dnl Use an explicit option to hardcode DIR into the resulting + dnl binary. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so" + dnl Potentially add DIR to rpathdirs. + dnl The rpathdirs will be appended to $LIBNAME at the end. + haveit= + for x in $rpathdirs; do + if test "X$x" = "X$found_dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + rpathdirs="$rpathdirs $found_dir" + fi + else + dnl Rely on "-L$found_dir". + dnl But don't add it if it's already contained in the LDFLAGS + dnl or the already constructed $LIBNAME + haveit= + for x in $LDFLAGS $LIB[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-L$found_dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$found_dir" + fi + if test "$acl_hardcode_minus_L" != no; then + dnl FIXME: Not sure whether we should use + dnl "-L$found_dir -l$name" or "-L$found_dir $found_so" + dnl here. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so" + else + dnl We cannot use $acl_hardcode_runpath_var and LD_RUN_PATH + dnl here, because this doesn't fit in flags passed to the + dnl compiler. So give up. No hardcoding. This affects only + dnl very old systems. + dnl FIXME: Not sure whether we should use + dnl "-L$found_dir -l$name" or "-L$found_dir $found_so" + dnl here. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-l$name" + fi + fi + fi + fi + else + if test "X$found_a" != "X"; then + dnl Linking with a static library. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_a" + else + dnl We shouldn't come here, but anyway it's good to have a + dnl fallback. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$found_dir -l$name" + fi + fi + dnl Assume the include files are nearby. + additional_includedir= + case "$found_dir" in + */$acl_libdirstem | */$acl_libdirstem/) + basedir=`echo "X$found_dir" | sed -e 's,^X,,' -e "s,/$acl_libdirstem/"'*$,,'` + if test "$name" = '$1'; then + LIB[]NAME[]_PREFIX="$basedir" + fi + additional_includedir="$basedir/include" + ;; + */$acl_libdirstem2 | */$acl_libdirstem2/) + basedir=`echo "X$found_dir" | sed -e 's,^X,,' -e "s,/$acl_libdirstem2/"'*$,,'` + if test "$name" = '$1'; then + LIB[]NAME[]_PREFIX="$basedir" + fi + additional_includedir="$basedir/include" + ;; + esac + if test "X$additional_includedir" != "X"; then + dnl Potentially add $additional_includedir to $INCNAME. + dnl But don't add it + dnl 1. if it's the standard /usr/include, + dnl 2. if it's /usr/local/include and we are using GCC on Linux, + dnl 3. if it's already present in $CPPFLAGS or the already + dnl constructed $INCNAME, + dnl 4. if it doesn't exist as a directory. + if test "X$additional_includedir" != "X/usr/include"; then + haveit= + if test "X$additional_includedir" = "X/usr/local/include"; then + if test -n "$GCC"; then + case $host_os in + linux* | gnu* | k*bsd*-gnu) haveit=yes;; + esac + fi + fi + if test -z "$haveit"; then + for x in $CPPFLAGS $INC[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-I$additional_includedir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test -d "$additional_includedir"; then + dnl Really add $additional_includedir to $INCNAME. + INC[]NAME="${INC[]NAME}${INC[]NAME:+ }-I$additional_includedir" + fi + fi + fi + fi + fi + dnl Look for dependencies. + if test -n "$found_la"; then + dnl Read the .la file. It defines the variables + dnl dlname, library_names, old_library, dependency_libs, current, + dnl age, revision, installed, dlopen, dlpreopen, libdir. + save_libdir="$libdir" + case "$found_la" in + */* | *\\*) . "$found_la" ;; + *) . "./$found_la" ;; + esac + libdir="$save_libdir" + dnl We use only dependency_libs. + for dep in $dependency_libs; do + case "$dep" in + -L*) + additional_libdir=`echo "X$dep" | sed -e 's/^X-L//'` + dnl Potentially add $additional_libdir to $LIBNAME and $LTLIBNAME. + dnl But don't add it + dnl 1. if it's the standard /usr/lib, + dnl 2. if it's /usr/local/lib and we are using GCC on Linux, + dnl 3. if it's already present in $LDFLAGS or the already + dnl constructed $LIBNAME, + dnl 4. if it doesn't exist as a directory. + if test "X$additional_libdir" != "X/usr/$acl_libdirstem" \ + && test "X$additional_libdir" != "X/usr/$acl_libdirstem2"; then + haveit= + if test "X$additional_libdir" = "X/usr/local/$acl_libdirstem" \ + || test "X$additional_libdir" = "X/usr/local/$acl_libdirstem2"; then + if test -n "$GCC"; then + case $host_os in + linux* | gnu* | k*bsd*-gnu) haveit=yes;; + esac + fi + fi + if test -z "$haveit"; then + haveit= + for x in $LDFLAGS $LIB[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-L$additional_libdir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test -d "$additional_libdir"; then + dnl Really add $additional_libdir to $LIBNAME. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$additional_libdir" + fi + fi + haveit= + for x in $LDFLAGS $LTLIB[]NAME; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-L$additional_libdir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test -d "$additional_libdir"; then + dnl Really add $additional_libdir to $LTLIBNAME. + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-L$additional_libdir" + fi + fi + fi + fi + ;; + -R*) + dir=`echo "X$dep" | sed -e 's/^X-R//'` + if test "$enable_rpath" != no; then + dnl Potentially add DIR to rpathdirs. + dnl The rpathdirs will be appended to $LIBNAME at the end. + haveit= + for x in $rpathdirs; do + if test "X$x" = "X$dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + rpathdirs="$rpathdirs $dir" + fi + dnl Potentially add DIR to ltrpathdirs. + dnl The ltrpathdirs will be appended to $LTLIBNAME at the end. + haveit= + for x in $ltrpathdirs; do + if test "X$x" = "X$dir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + ltrpathdirs="$ltrpathdirs $dir" + fi + fi + ;; + -l*) + dnl Handle this in the next round. + names_next_round="$names_next_round "`echo "X$dep" | sed -e 's/^X-l//'` + ;; + *.la) + dnl Handle this in the next round. Throw away the .la's + dnl directory; it is already contained in a preceding -L + dnl option. + names_next_round="$names_next_round "`echo "X$dep" | sed -e 's,^X.*/,,' -e 's,^lib,,' -e 's,\.la$,,'` + ;; + *) + dnl Most likely an immediate library name. + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$dep" + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }$dep" + ;; + esac + done + fi + else + dnl Didn't find the library; assume it is in the system directories + dnl known to the linker and runtime loader. (All the system + dnl directories known to the linker should also be known to the + dnl runtime loader, otherwise the system is severely misconfigured.) + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-l$name" + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-l$name" + fi + fi + fi + done + done + if test "X$rpathdirs" != "X"; then + if test -n "$acl_hardcode_libdir_separator"; then + dnl Weird platform: only the last -rpath option counts, the user must + dnl pass all path elements in one option. We can arrange that for a + dnl single library, but not when more than one $LIBNAMEs are used. + alldirs= + for found_dir in $rpathdirs; do + alldirs="${alldirs}${alldirs:+$acl_hardcode_libdir_separator}$found_dir" + done + dnl Note: acl_hardcode_libdir_flag_spec uses $libdir and $wl. + acl_save_libdir="$libdir" + libdir="$alldirs" + eval flag=\"$acl_hardcode_libdir_flag_spec\" + libdir="$acl_save_libdir" + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$flag" + else + dnl The -rpath options are cumulative. + for found_dir in $rpathdirs; do + acl_save_libdir="$libdir" + libdir="$found_dir" + eval flag=\"$acl_hardcode_libdir_flag_spec\" + libdir="$acl_save_libdir" + LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$flag" + done + fi + fi + if test "X$ltrpathdirs" != "X"; then + dnl When using libtool, the option that works for both libraries and + dnl executables is -R. The -R options are cumulative. + for found_dir in $ltrpathdirs; do + LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-R$found_dir" + done + fi + popdef([P_A_C_K]) + popdef([PACKLIBS]) + popdef([PACKUP]) + popdef([PACK]) + popdef([NAME]) +]) + +dnl AC_LIB_APPENDTOVAR(VAR, CONTENTS) appends the elements of CONTENTS to VAR, +dnl unless already present in VAR. +dnl Works only for CPPFLAGS, not for LIB* variables because that sometimes +dnl contains two or three consecutive elements that belong together. +AC_DEFUN([AC_LIB_APPENDTOVAR], +[ + for element in [$2]; do + haveit= + for x in $[$1]; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X$element"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + [$1]="${[$1]}${[$1]:+ }$element" + fi + done +]) + +dnl For those cases where a variable contains several -L and -l options +dnl referring to unknown libraries and directories, this macro determines the +dnl necessary additional linker options for the runtime path. +dnl AC_LIB_LINKFLAGS_FROM_LIBS([LDADDVAR], [LIBSVALUE], [USE-LIBTOOL]) +dnl sets LDADDVAR to linker options needed together with LIBSVALUE. +dnl If USE-LIBTOOL evaluates to non-empty, linking with libtool is assumed, +dnl otherwise linking without libtool is assumed. +AC_DEFUN([AC_LIB_LINKFLAGS_FROM_LIBS], +[ + AC_REQUIRE([AC_LIB_RPATH]) + AC_REQUIRE([AC_LIB_PREPARE_MULTILIB]) + $1= + if test "$enable_rpath" != no; then + if test -n "$acl_hardcode_libdir_flag_spec" && test "$acl_hardcode_minus_L" = no; then + dnl Use an explicit option to hardcode directories into the resulting + dnl binary. + rpathdirs= + next= + for opt in $2; do + if test -n "$next"; then + dir="$next" + dnl No need to hardcode the standard /usr/lib. + if test "X$dir" != "X/usr/$acl_libdirstem" \ + && test "X$dir" != "X/usr/$acl_libdirstem2"; then + rpathdirs="$rpathdirs $dir" + fi + next= + else + case $opt in + -L) next=yes ;; + -L*) dir=`echo "X$opt" | sed -e 's,^X-L,,'` + dnl No need to hardcode the standard /usr/lib. + if test "X$dir" != "X/usr/$acl_libdirstem" \ + && test "X$dir" != "X/usr/$acl_libdirstem2"; then + rpathdirs="$rpathdirs $dir" + fi + next= ;; + *) next= ;; + esac + fi + done + if test "X$rpathdirs" != "X"; then + if test -n ""$3""; then + dnl libtool is used for linking. Use -R options. + for dir in $rpathdirs; do + $1="${$1}${$1:+ }-R$dir" + done + else + dnl The linker is used for linking directly. + if test -n "$acl_hardcode_libdir_separator"; then + dnl Weird platform: only the last -rpath option counts, the user + dnl must pass all path elements in one option. + alldirs= + for dir in $rpathdirs; do + alldirs="${alldirs}${alldirs:+$acl_hardcode_libdir_separator}$dir" + done + acl_save_libdir="$libdir" + libdir="$alldirs" + eval flag=\"$acl_hardcode_libdir_flag_spec\" + libdir="$acl_save_libdir" + $1="$flag" + else + dnl The -rpath options are cumulative. + for dir in $rpathdirs; do + acl_save_libdir="$libdir" + libdir="$dir" + eval flag=\"$acl_hardcode_libdir_flag_spec\" + libdir="$acl_save_libdir" + $1="${$1}${$1:+ }$flag" + done + fi + fi + fi + fi + fi + AC_SUBST([$1]) +]) diff --git a/m4/lib-prefix.m4 b/m4/lib-prefix.m4 new file mode 100644 index 000000000..4b7ee3358 --- /dev/null +++ b/m4/lib-prefix.m4 @@ -0,0 +1,224 @@ +# lib-prefix.m4 serial 7 (gettext-0.18) +dnl Copyright (C) 2001-2005, 2008-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free 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 AC_LIB_ARG_WITH is synonymous to AC_ARG_WITH in autoconf-2.13, and +dnl similar to AC_ARG_WITH in autoconf 2.52...2.57 except that is doesn't +dnl require excessive bracketing. +ifdef([AC_HELP_STRING], +[AC_DEFUN([AC_LIB_ARG_WITH], [AC_ARG_WITH([$1],[[$2]],[$3],[$4])])], +[AC_DEFUN([AC_][LIB_ARG_WITH], [AC_ARG_WITH([$1],[$2],[$3],[$4])])]) + +dnl AC_LIB_PREFIX adds to the CPPFLAGS and LDFLAGS the flags that are needed +dnl to access previously installed libraries. The basic assumption is that +dnl a user will want packages to use other packages he previously installed +dnl with the same --prefix option. +dnl This macro is not needed if only AC_LIB_LINKFLAGS is used to locate +dnl libraries, but is otherwise very convenient. +AC_DEFUN([AC_LIB_PREFIX], +[ + AC_BEFORE([$0], [AC_LIB_LINKFLAGS]) + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) + AC_REQUIRE([AC_LIB_PREPARE_MULTILIB]) + AC_REQUIRE([AC_LIB_PREPARE_PREFIX]) + dnl By default, look in $includedir and $libdir. + use_additional=yes + AC_LIB_WITH_FINAL_PREFIX([ + eval additional_includedir=\"$includedir\" + eval additional_libdir=\"$libdir\" + ]) + AC_LIB_ARG_WITH([lib-prefix], +[ --with-lib-prefix[=DIR] search for libraries in DIR/include and DIR/lib + --without-lib-prefix don't search for libraries in includedir and libdir], +[ + if test "X$withval" = "Xno"; then + use_additional=no + else + if test "X$withval" = "X"; then + AC_LIB_WITH_FINAL_PREFIX([ + eval additional_includedir=\"$includedir\" + eval additional_libdir=\"$libdir\" + ]) + else + additional_includedir="$withval/include" + additional_libdir="$withval/$acl_libdirstem" + fi + fi +]) + if test $use_additional = yes; then + dnl Potentially add $additional_includedir to $CPPFLAGS. + dnl But don't add it + dnl 1. if it's the standard /usr/include, + dnl 2. if it's already present in $CPPFLAGS, + dnl 3. if it's /usr/local/include and we are using GCC on Linux, + dnl 4. if it doesn't exist as a directory. + if test "X$additional_includedir" != "X/usr/include"; then + haveit= + for x in $CPPFLAGS; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-I$additional_includedir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test "X$additional_includedir" = "X/usr/local/include"; then + if test -n "$GCC"; then + case $host_os in + linux* | gnu* | k*bsd*-gnu) haveit=yes;; + esac + fi + fi + if test -z "$haveit"; then + if test -d "$additional_includedir"; then + dnl Really add $additional_includedir to $CPPFLAGS. + CPPFLAGS="${CPPFLAGS}${CPPFLAGS:+ }-I$additional_includedir" + fi + fi + fi + fi + dnl Potentially add $additional_libdir to $LDFLAGS. + dnl But don't add it + dnl 1. if it's the standard /usr/lib, + dnl 2. if it's already present in $LDFLAGS, + dnl 3. if it's /usr/local/lib and we are using GCC on Linux, + dnl 4. if it doesn't exist as a directory. + if test "X$additional_libdir" != "X/usr/$acl_libdirstem"; then + haveit= + for x in $LDFLAGS; do + AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"]) + if test "X$x" = "X-L$additional_libdir"; then + haveit=yes + break + fi + done + if test -z "$haveit"; then + if test "X$additional_libdir" = "X/usr/local/$acl_libdirstem"; then + if test -n "$GCC"; then + case $host_os in + linux*) haveit=yes;; + esac + fi + fi + if test -z "$haveit"; then + if test -d "$additional_libdir"; then + dnl Really add $additional_libdir to $LDFLAGS. + LDFLAGS="${LDFLAGS}${LDFLAGS:+ }-L$additional_libdir" + fi + fi + fi + fi + fi +]) + +dnl AC_LIB_PREPARE_PREFIX creates variables acl_final_prefix, +dnl acl_final_exec_prefix, containing the values to which $prefix and +dnl $exec_prefix will expand at the end of the configure script. +AC_DEFUN([AC_LIB_PREPARE_PREFIX], +[ + dnl Unfortunately, prefix and exec_prefix get only finally determined + dnl at the end of configure. + if test "X$prefix" = "XNONE"; then + acl_final_prefix="$ac_default_prefix" + else + acl_final_prefix="$prefix" + fi + if test "X$exec_prefix" = "XNONE"; then + acl_final_exec_prefix='${prefix}' + else + acl_final_exec_prefix="$exec_prefix" + fi + acl_save_prefix="$prefix" + prefix="$acl_final_prefix" + eval acl_final_exec_prefix=\"$acl_final_exec_prefix\" + prefix="$acl_save_prefix" +]) + +dnl AC_LIB_WITH_FINAL_PREFIX([statement]) evaluates statement, with the +dnl variables prefix and exec_prefix bound to the values they will have +dnl at the end of the configure script. +AC_DEFUN([AC_LIB_WITH_FINAL_PREFIX], +[ + acl_save_prefix="$prefix" + prefix="$acl_final_prefix" + acl_save_exec_prefix="$exec_prefix" + exec_prefix="$acl_final_exec_prefix" + $1 + exec_prefix="$acl_save_exec_prefix" + prefix="$acl_save_prefix" +]) + +dnl AC_LIB_PREPARE_MULTILIB creates +dnl - a variable acl_libdirstem, containing the basename of the libdir, either +dnl "lib" or "lib64" or "lib/64", +dnl - a variable acl_libdirstem2, as a secondary possible value for +dnl acl_libdirstem, either the same as acl_libdirstem or "lib/sparcv9" or +dnl "lib/amd64". +AC_DEFUN([AC_LIB_PREPARE_MULTILIB], +[ + dnl There is no formal standard regarding lib and lib64. + dnl On glibc systems, the current practice is that on a system supporting + dnl 32-bit and 64-bit instruction sets or ABIs, 64-bit libraries go under + dnl $prefix/lib64 and 32-bit libraries go under $prefix/lib. We determine + dnl the compiler's default mode by looking at the compiler's library search + dnl path. If at least one of its elements ends in /lib64 or points to a + dnl directory whose absolute pathname ends in /lib64, we assume a 64-bit ABI. + dnl Otherwise we use the default, namely "lib". + dnl On Solaris systems, the current practice is that on a system supporting + dnl 32-bit and 64-bit instruction sets or ABIs, 64-bit libraries go under + dnl $prefix/lib/64 (which is a symlink to either $prefix/lib/sparcv9 or + dnl $prefix/lib/amd64) and 32-bit libraries go under $prefix/lib. + AC_REQUIRE([AC_CANONICAL_HOST]) + acl_libdirstem=lib + acl_libdirstem2= + case "$host_os" in + solaris*) + dnl See Solaris 10 Software Developer Collection > Solaris 64-bit Developer's Guide > The Development Environment + dnl . + dnl "Portable Makefiles should refer to any library directories using the 64 symbolic link." + dnl But we want to recognize the sparcv9 or amd64 subdirectory also if the + dnl symlink is missing, so we set acl_libdirstem2 too. + AC_CACHE_CHECK([for 64-bit host], [gl_cv_solaris_64bit], + [AC_EGREP_CPP([sixtyfour bits], [ +#ifdef _LP64 +sixtyfour bits +#endif + ], [gl_cv_solaris_64bit=yes], [gl_cv_solaris_64bit=no]) + ]) + if test $gl_cv_solaris_64bit = yes; then + acl_libdirstem=lib/64 + case "$host_cpu" in + sparc*) acl_libdirstem2=lib/sparcv9 ;; + i*86 | x86_64) acl_libdirstem2=lib/amd64 ;; + esac + fi + ;; + *) + searchpath=`(LC_ALL=C $CC -print-search-dirs) 2>/dev/null | sed -n -e 's,^libraries: ,,p' | sed -e 's,^=,,'` + if test -n "$searchpath"; then + acl_save_IFS="${IFS= }"; IFS=":" + for searchdir in $searchpath; do + if test -d "$searchdir"; then + case "$searchdir" in + */lib64/ | */lib64 ) acl_libdirstem=lib64 ;; + */../ | */.. ) + # Better ignore directories of this form. They are misleading. + ;; + *) searchdir=`cd "$searchdir" && pwd` + case "$searchdir" in + */lib64 ) acl_libdirstem=lib64 ;; + esac ;; + esac + fi + done + IFS="$acl_save_IFS" + fi + ;; + esac + test -n "$acl_libdirstem2" || acl_libdirstem2="$acl_libdirstem" +]) diff --git a/m4/libunistring.m4 b/m4/libunistring.m4 new file mode 100644 index 000000000..52ff06b61 --- /dev/null +++ b/m4/libunistring.m4 @@ -0,0 +1,37 @@ +# libunistring.m4 serial 1 +dnl Copyright (C) 2009 Free Software Foundation, Inc. +dnl This file is free software; the Free 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 gl_LIBUNISTRING +dnl Searches for an installed libunistring. +dnl If found, it sets and AC_SUBSTs HAVE_LIBUNISTRING=yes and the LIBUNISTRING +dnl and LTLIBUNISTRING variables and augments the CPPFLAGS variable, and +dnl #defines HAVE_LIBUNISTRING to 1. Otherwise, it sets and AC_SUBSTs +dnl HAVE_LIBUNISTRING=no and LIBUNINSTRING and LTLIBUNISTRING to empty. + +AC_DEFUN([gl_LIBUNISTRING], +[ + dnl First, try to link without -liconv. libunistring often depends on + dnl libiconv, but we don't know (and often don't need to know) where + dnl libiconv is installed. + AC_LIB_HAVE_LINKFLAGS([unistring], [], + [#include ], [u8_strconv_from_locale((char*)0);], + [no, consider installing GNU libunistring]) + if test "$ac_cv_libunistring" != yes; then + dnl Second try, with -liconv. + AC_REQUIRE([AM_ICONV]) + if test -n "$LIBICONV"; then + glus_save_LIBS="$LIBS" + LIBS="$LIBS $LIBICONV" + AC_LIB_HAVE_LINKFLAGS([unistring], [], + [#include ], [u8_strconv_from_locale((char*)0);], + [no, consider installing GNU libunistring]) + if test -n "$LIBUNISTRING"; then + LIBUNISTRING="$LIBUNISTRING $LIBICONV" + fi + LIBS="$glus_save_LIBS" + fi + fi +]) diff --git a/m4/string_h.m4 b/m4/string_h.m4 new file mode 100644 index 000000000..2d5553c37 --- /dev/null +++ b/m4/string_h.m4 @@ -0,0 +1,92 @@ +# Configure a GNU-like replacement for . + +# Copyright (C) 2007, 2008 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. + +# serial 6 + +# Written by Paul Eggert. + +AC_DEFUN([gl_HEADER_STRING_H], +[ + dnl Use AC_REQUIRE here, so that the default behavior below is expanded + dnl once only, before all statements that occur in other macros. + AC_REQUIRE([gl_HEADER_STRING_H_BODY]) +]) + +AC_DEFUN([gl_HEADER_STRING_H_BODY], +[ + AC_REQUIRE([AC_C_RESTRICT]) + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + gl_CHECK_NEXT_HEADERS([string.h]) +]) + +AC_DEFUN([gl_STRING_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) + GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1 +]) + +AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS], +[ + GNULIB_MEMMEM=0; AC_SUBST([GNULIB_MEMMEM]) + GNULIB_MEMPCPY=0; AC_SUBST([GNULIB_MEMPCPY]) + GNULIB_MEMRCHR=0; AC_SUBST([GNULIB_MEMRCHR]) + GNULIB_RAWMEMCHR=0; AC_SUBST([GNULIB_RAWMEMCHR]) + GNULIB_STPCPY=0; AC_SUBST([GNULIB_STPCPY]) + GNULIB_STPNCPY=0; AC_SUBST([GNULIB_STPNCPY]) + GNULIB_STRCHRNUL=0; AC_SUBST([GNULIB_STRCHRNUL]) + GNULIB_STRDUP=0; AC_SUBST([GNULIB_STRDUP]) + GNULIB_STRNDUP=0; AC_SUBST([GNULIB_STRNDUP]) + GNULIB_STRNLEN=0; AC_SUBST([GNULIB_STRNLEN]) + GNULIB_STRPBRK=0; AC_SUBST([GNULIB_STRPBRK]) + GNULIB_STRSEP=0; AC_SUBST([GNULIB_STRSEP]) + GNULIB_STRSTR=0; AC_SUBST([GNULIB_STRSTR]) + GNULIB_STRCASESTR=0; AC_SUBST([GNULIB_STRCASESTR]) + GNULIB_STRTOK_R=0; AC_SUBST([GNULIB_STRTOK_R]) + GNULIB_MBSLEN=0; AC_SUBST([GNULIB_MBSLEN]) + GNULIB_MBSNLEN=0; AC_SUBST([GNULIB_MBSNLEN]) + GNULIB_MBSCHR=0; AC_SUBST([GNULIB_MBSCHR]) + GNULIB_MBSRCHR=0; AC_SUBST([GNULIB_MBSRCHR]) + GNULIB_MBSSTR=0; AC_SUBST([GNULIB_MBSSTR]) + GNULIB_MBSCASECMP=0; AC_SUBST([GNULIB_MBSCASECMP]) + GNULIB_MBSNCASECMP=0; AC_SUBST([GNULIB_MBSNCASECMP]) + GNULIB_MBSPCASECMP=0; AC_SUBST([GNULIB_MBSPCASECMP]) + GNULIB_MBSCASESTR=0; AC_SUBST([GNULIB_MBSCASESTR]) + GNULIB_MBSCSPN=0; AC_SUBST([GNULIB_MBSCSPN]) + GNULIB_MBSPBRK=0; AC_SUBST([GNULIB_MBSPBRK]) + GNULIB_MBSSPN=0; AC_SUBST([GNULIB_MBSSPN]) + GNULIB_MBSSEP=0; AC_SUBST([GNULIB_MBSSEP]) + GNULIB_MBSTOK_R=0; AC_SUBST([GNULIB_MBSTOK_R]) + GNULIB_STRERROR=0; AC_SUBST([GNULIB_STRERROR]) + GNULIB_STRSIGNAL=0; AC_SUBST([GNULIB_STRSIGNAL]) + GNULIB_STRVERSCMP=0; AC_SUBST([GNULIB_STRVERSCMP]) + dnl Assume proper GNU behavior unless another module says otherwise. + HAVE_DECL_MEMMEM=1; AC_SUBST([HAVE_DECL_MEMMEM]) + HAVE_MEMPCPY=1; AC_SUBST([HAVE_MEMPCPY]) + HAVE_DECL_MEMRCHR=1; AC_SUBST([HAVE_DECL_MEMRCHR]) + HAVE_RAWMEMCHR=1; AC_SUBST([HAVE_RAWMEMCHR]) + HAVE_STPCPY=1; AC_SUBST([HAVE_STPCPY]) + HAVE_STPNCPY=1; AC_SUBST([HAVE_STPNCPY]) + HAVE_STRCHRNUL=1; AC_SUBST([HAVE_STRCHRNUL]) + HAVE_DECL_STRDUP=1; AC_SUBST([HAVE_DECL_STRDUP]) + HAVE_STRNDUP=1; AC_SUBST([HAVE_STRNDUP]) + HAVE_DECL_STRNDUP=1; AC_SUBST([HAVE_DECL_STRNDUP]) + HAVE_DECL_STRNLEN=1; AC_SUBST([HAVE_DECL_STRNLEN]) + HAVE_STRPBRK=1; AC_SUBST([HAVE_STRPBRK]) + HAVE_STRSEP=1; AC_SUBST([HAVE_STRSEP]) + HAVE_STRCASESTR=1; AC_SUBST([HAVE_STRCASESTR]) + HAVE_DECL_STRTOK_R=1; AC_SUBST([HAVE_DECL_STRTOK_R]) + HAVE_DECL_STRERROR=1; AC_SUBST([HAVE_DECL_STRERROR]) + HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL]) + HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP]) + REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM]) + REPLACE_STRDUP=0; AC_SUBST([REPLACE_STRDUP]) + REPLACE_STRSTR=0; AC_SUBST([REPLACE_STRSTR]) + REPLACE_STRCASESTR=0; AC_SUBST([REPLACE_STRCASESTR]) + REPLACE_STRERROR=0; AC_SUBST([REPLACE_STRERROR]) + REPLACE_STRSIGNAL=0; AC_SUBST([REPLACE_STRSIGNAL]) +]) diff --git a/m4/visibility.m4 b/m4/visibility.m4 new file mode 100644 index 000000000..70bca5643 --- /dev/null +++ b/m4/visibility.m4 @@ -0,0 +1,52 @@ +# visibility.m4 serial 2 (gettext-0.18) +dnl Copyright (C) 2005, 2008 Free Software Foundation, Inc. +dnl This file is free software; the Free 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 Tests whether the compiler supports the command-line option +dnl -fvisibility=hidden and the function and variable attributes +dnl __attribute__((__visibility__("hidden"))) and +dnl __attribute__((__visibility__("default"))). +dnl Does *not* test for __visibility__("protected") - which has tricky +dnl semantics (see the 'vismain' test in glibc) and does not exist e.g. on +dnl MacOS X. +dnl Does *not* test for __visibility__("internal") - which has processor +dnl dependent semantics. +dnl Does *not* test for #pragma GCC visibility push(hidden) - which is +dnl "really only recommended for legacy code". +dnl Set the variable CFLAG_VISIBILITY. +dnl Defines and sets the variable HAVE_VISIBILITY. + +AC_DEFUN([gl_VISIBILITY], +[ + AC_REQUIRE([AC_PROG_CC]) + CFLAG_VISIBILITY= + HAVE_VISIBILITY=0 + if test -n "$GCC"; then + AC_MSG_CHECKING([for simple visibility declarations]) + AC_CACHE_VAL([gl_cv_cc_visibility], [ + gl_save_CFLAGS="$CFLAGS" + CFLAGS="$CFLAGS -fvisibility=hidden" + AC_TRY_COMPILE( + [extern __attribute__((__visibility__("hidden"))) int hiddenvar; + extern __attribute__((__visibility__("default"))) int exportedvar; + extern __attribute__((__visibility__("hidden"))) int hiddenfunc (void); + extern __attribute__((__visibility__("default"))) int exportedfunc (void);], + [], + [gl_cv_cc_visibility=yes], + [gl_cv_cc_visibility=no]) + CFLAGS="$gl_save_CFLAGS"]) + AC_MSG_RESULT([$gl_cv_cc_visibility]) + if test $gl_cv_cc_visibility = yes; then + CFLAG_VISIBILITY="-fvisibility=hidden" + HAVE_VISIBILITY=1 + fi + fi + AC_SUBST([CFLAG_VISIBILITY]) + AC_SUBST([HAVE_VISIBILITY]) + AC_DEFINE_UNQUOTED([HAVE_VISIBILITY], [$HAVE_VISIBILITY], + [Define to 1 or 0, depending whether the compiler supports simple visibility declarations.]) +]) diff --git a/module/Makefile.am b/module/Makefile.am index 95dc75ac2..9d9a839a1 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -31,30 +31,25 @@ modpath = # putting these core modules first. SOURCES = \ - ice-9/psyntax-pp.scm \ + ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ \ - system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \ - system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \ - system/vm/trace.scm system/vm/vm.scm \ - \ - system/xref.scm \ - \ - system/repl/repl.scm system/repl/common.scm \ - system/repl/command.scm \ - \ + language/tree-il.scm \ language/ghil.scm language/glil.scm language/assembly.scm \ \ - $(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \ + $(SCHEME_LANG_SOURCES) \ + $(TREE_IL_LANG_SOURCES) \ $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ \ $(ICE_9_SOURCES) \ $(SRFI_SOURCES) \ + $(RNRS_SOURCES) \ $(OOP_SOURCES) \ - \ + $(SYSTEM_SOURCES) \ + $(ECMASCRIPT_LANG_SOURCES) \ $(SCRIPTS_SOURCES) ## test.scm is not currently installed. @@ -71,10 +66,19 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm SCHEME_LANG_SOURCES = \ - language/scheme/amatch.scm language/scheme/expand.scm \ - language/scheme/compile-ghil.scm language/scheme/spec.scm \ + language/scheme/compile-ghil.scm \ + language/scheme/spec.scm \ + language/scheme/compile-tree-il.scm \ + language/scheme/decompile-tree-il.scm \ language/scheme/inline.scm +TREE_IL_LANG_SOURCES = \ + language/tree-il/primitives.scm \ + language/tree-il/optimize.scm \ + language/tree-il/analyze.scm \ + language/tree-il/compile-glil.scm \ + language/tree-il/spec.scm + GHIL_LANG_SOURCES = \ language/ghil/spec.scm language/ghil/compile-glil.scm @@ -140,7 +144,6 @@ ICE_9_SOURCES = \ ice-9/debugger.scm \ ice-9/documentation.scm \ ice-9/emacs.scm \ - ice-9/expand-support.scm \ ice-9/expect.scm \ ice-9/format.scm \ ice-9/getopt-long.scm \ @@ -198,6 +201,7 @@ SRFI_SOURCES = \ 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-31.scm \ @@ -209,6 +213,10 @@ SRFI_SOURCES = \ srfi/srfi-69.scm \ srfi/srfi-88.scm +RNRS_SOURCES = \ + rnrs/bytevector.scm \ + rnrs/io/ports.scm + EXTRA_DIST += scripts/ChangeLog-2008 EXTRA_DIST += scripts/README @@ -226,6 +234,16 @@ OOP_SOURCES = \ oop/goops/accessors.scm \ oop/goops/simple.scm +SYSTEM_SOURCES = \ + system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \ + system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \ + system/vm/trace.scm system/vm/vm.scm \ + \ + system/xref.scm \ + \ + system/repl/repl.scm system/repl/common.scm \ + system/repl/command.scm + EXTRA_DIST += oop/ChangeLog-2008 NOCOMP_SOURCES = \ @@ -242,5 +260,4 @@ NOCOMP_SOURCES = \ ice-9/debugging/steps.scm \ ice-9/debugging/trace.scm \ ice-9/debugging/traps.scm \ - ice-9/debugging/trc.scm \ - srfi/srfi-18.scm + ice-9/debugging/trc.scm diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 48d822bfc..44066312a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -33,6 +33,13 @@ +;; Before compiling, make sure any symbols are resolved in the (guile) +;; module, the primary location of those symbols, rather than in +;; (guile-user), the default module that we compile in. + +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + ;;; {R4RS compliance} ;;; @@ -86,6 +93,42 @@ (define (provided? feature) (and (memq feature *features*) #t)) + + +;;; {and-map and or-map} +;;; +;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) +;;; (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) + (let loop ((result #t) + (l lst)) + (and result + (or (and (null? l) + 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) + (let loop ((result #f) + (l lst)) + (or result + (and (not (null? l)) + (loop (f (car l)) (cdr l)))))) + + + ;; let format alias simple-format until the more complete version is loaded (define format simple-format) @@ -125,97 +168,181 @@ -;; Before the module system boots, there are no module names. But -;; psyntax does want a module-name definition, so give it one. +;; Define a minimal stub of the module API for psyntax, before modules +;; have booted. (define (module-name x) + '(guile)) +(define (module-define! module sym val) + (let ((v (hashq-ref (%get-pre-modules-obarray) sym))) + (if v + (variable-set! v val) + (hashq-set! (%get-pre-modules-obarray) sym + (make-variable val))))) +(define (module-ref module sym) + (let ((v (module-variable module sym))) + (if v (variable-ref v) (error "badness!" (pk module) (pk sym))))) +(define (resolve-module . args) #f) -;; (eval-when (situation...) form...) -;; -;; Evaluate certain code based on the situation that eval-when is used -;; in. There are three situations defined. -;; -;; `load' triggers when a file is loaded via `load', or when a compiled -;; file is loaded. -;; -;; `compile' triggers when an expression is compiled. -;; -;; `eval' triggers when code is evaluated interactively, as at the REPL -;; or via the `compile' or `eval' procedures. +;; Input hook to syncase -- so that we might be able to pass annotated +;; expressions in. Currently disabled. Maybe we should just use +;; source-properties directly. +(define (annotation? x) #f) -;; NB: this macro is only ever expanded by the interpreter. The compiler -;; notices it and interprets the situations differently. -(define eval-when - (procedure->memoizing-macro - (lambda (exp env) - (let ((situations (cadr exp)) - (body (cddr exp))) - (if (or (memq 'load situations) - (memq 'eval situations)) - `(begin . ,body)))))) +;; API provided by psyntax +(define syntax-violation #f) +(define datum->syntax #f) +(define syntax->datum #f) +(define identifier? #f) +(define generate-temporaries #f) +(define bound-identifier=? #f) +(define free-identifier=? #f) +(define sc-expand #f) + +;; $sc-expand is an implementation detail of psyntax. It is used by +;; expanded macros, to dispatch an input against a set of patterns. +(define $sc-dispatch #f) + +;; Load it up! +(primitive-load-path "ice-9/psyntax-pp") + +;; %pre-modules-transformer is the Scheme expander from now until the +;; module system has booted up. +(define %pre-modules-transformer sc-expand) + +(define-syntax and + (syntax-rules () + ((_) #t) + ((_ x) x) + ((_ x y ...) (if x (and y ...) #f)))) + +(define-syntax or + (syntax-rules () + ((_) #f) + ((_ x) x) + ((_ x y ...) (let ((t x)) (if t t (or y ...)))))) + +;; The "maybe-more" bits are something of a hack, so that we can support +;; SRFI-61. Rewrites into a standalone syntax-case macro would be +;; appreciated. +(define-syntax cond + (syntax-rules (=> else) + ((_ "maybe-more" test consequent) + (if test consequent)) + + ((_ "maybe-more" test consequent clause ...) + (if test consequent (cond clause ...))) + + ((_ (else else1 else2 ...)) + (begin else1 else2 ...)) + + ((_ (test => receiver) more-clause ...) + (let ((t test)) + (cond "maybe-more" t (receiver t) more-clause ...))) + + ((_ (generator guard => receiver) more-clause ...) + (call-with-values (lambda () generator) + (lambda t + (cond "maybe-more" + (apply guard t) (apply receiver t) more-clause ...)))) + + ((_ (test => receiver ...) more-clause ...) + (syntax-violation 'cond "wrong number of receiver expressions" + '(test => receiver ...))) + ((_ (generator guard => receiver ...) more-clause ...) + (syntax-violation 'cond "wrong number of receiver expressions" + '(generator guard => receiver ...))) + + ((_ (test) more-clause ...) + (let ((t test)) + (cond "maybe-more" t t more-clause ...))) + + ((_ (test body1 body2 ...) more-clause ...) + (cond "maybe-more" + test (begin body1 body2 ...) more-clause ...)))) + +(define-syntax case + (syntax-rules (else) + ((case (key ...) + clauses ...) + (let ((atom-key (key ...))) + (case atom-key clauses ...))) + ((case key + (else result1 result2 ...)) + (begin result1 result2 ...)) + ((case key + ((atoms ...) result1 result2 ...)) + (if (memv key '(atoms ...)) + (begin result1 result2 ...))) + ((case key + ((atoms ...) result1 result2 ...) + clause clauses ...) + (if (memv key '(atoms ...)) + (begin result1 result2 ...) + (case key clause clauses ...))))) + +(define-syntax do + (syntax-rules () + ((do ((var init step ...) ...) + (test expr ...) + command ...) + (letrec + ((loop + (lambda (var ...) + (if test + (begin + (if #f #f) + expr ...) + (begin + command + ... + (loop (do "step" var step ...) + ...)))))) + (loop init ...))) + ((do "step" x) + x) + ((do "step" x y) + y))) + +(define-syntax delay + (syntax-rules () + ((_ exp) (make-promise (lambda () exp))))) -;; Before compiling, make sure any symbols are resolved in the (guile) -;; module, the primary location of those symbols, rather than in -;; (guile-user), the default module that we compile in. - -(eval-when (compile) - (set-current-module (resolve-module '(guile)))) - ;;; {Defmacros} ;;; -;;; Depends on: features, eval-case -;;; -(define macro-table (make-weak-key-hash-table 61)) -(define xformer-table (make-weak-key-hash-table 61)) +(define-syntax define-macro + (lambda (x) + "Define a defmacro." + (syntax-case x () + ((_ (macro . args) doc body1 body ...) + (string? (syntax->datum (syntax doc))) + (syntax (define-macro macro doc (lambda args body1 body ...)))) + ((_ (macro . args) body ...) + (syntax (define-macro macro #f (lambda args body ...)))) + ((_ macro doc transformer) + (or (string? (syntax->datum (syntax doc))) + (not (syntax->datum (syntax doc)))) + (syntax + (define-syntax macro + (lambda (y) + doc + (syntax-case y () + ((_ . args) + (let ((v (syntax->datum (syntax args)))) + (datum->syntax y (apply transformer v)))))))))))) -(define (defmacro? m) (hashq-ref macro-table m)) -(define (assert-defmacro?! m) (hashq-set! macro-table m #t)) -(define (defmacro-transformer m) (hashq-ref xformer-table m)) -(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t)) - -(define defmacro:transformer - (lambda (f) - (let* ((xform (lambda (exp env) - (copy-tree (apply f (cdr exp))))) - (a (procedure->memoizing-macro xform))) - (assert-defmacro?! a) - (set-defmacro-transformer! a f) - a))) - - -(define defmacro - (let ((defmacro-transformer - (lambda (name parms . body) - (let ((transformer `(lambda ,parms ,@body))) - `(eval-when - (eval load compile) - (define ,name (defmacro:transformer ,transformer))))))) - (defmacro:transformer defmacro-transformer))) - - -;; XXX - should the definition of the car really be looked up in the -;; current module? - -(define (macroexpand-1 e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (local-ref (list a))))) - (if (defmacro? val) - (apply (defmacro-transformer val) (cdr e)) - e))) - (#t e))) - -(define (macroexpand e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (local-ref (list a))))) - (if (defmacro? val) - (macroexpand (apply (defmacro-transformer val) (cdr e))) - e))) - (#t e))) +(define-syntax defmacro + (lambda (x) + "Define a defmacro, with the old lispy defun syntax." + (syntax-case x () + ((_ macro args doc body1 body ...) + (string? (syntax->datum (syntax doc))) + (syntax (define-macro macro doc (lambda args body1 body ...)))) + ((_ macro args body ...) + (syntax (define-macro macro #f (lambda args body ...))))))) (provide 'defmacro) @@ -477,40 +604,6 @@ -;;; {and-map and or-map} -;;; -;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) -;;; (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) - (let loop ((result #t) - (l lst)) - (and result - (or (and (null? l) - 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) - (let loop ((result #f) - (l lst)) - (or result - (and (not (null? l)) - (loop (f (car l)) (cdr l)))))) - - - (if (provided? 'posix) (primitive-load-path "ice-9/posix")) @@ -757,6 +850,26 @@ (start-stack 'load-stack (primitive-load-path name))) +(define %load-verbosely #f) +(define (assert-load-verbosity v) (set! %load-verbosely v)) + +(define (%load-announce file) + (if %load-verbosely + (with-output-to-port (current-error-port) + (lambda () + (display ";;; ") + (display "loading ") + (display file) + (newline) + (force-output))))) + +(set! %load-hook %load-announce) + +(define (load name . reader) + (with-fluid* current-reader (and (pair? reader) (car reader)) + (lambda () + (start-stack 'load-stack + (primitive-load name))))) @@ -848,9 +961,6 @@ ;;; Reader code for various "#c" forms. ;;; -(read-hash-extend #\' (lambda (c port) - (read port))) - (define read-eval? (make-fluid)) (fluid-set! read-eval? #f) (read-hash-extend #\. @@ -1133,11 +1243,8 @@ (define (%print-module mod port) ; unused args: depth length style table) (display "#<" port) (display (or (module-kind mod) "module") port) - (let ((name (module-name mod))) - (if name - (begin - (display " " port) - (display name port)))) + (display " " port) + (display (module-name mod) port) (display " " port) (display (number->string (object-address mod) 16) port) (display ">" port)) @@ -1194,7 +1301,8 @@ "Lazy-binder expected to be a procedure or #f." binder)) (let ((module (module-constructor (make-hash-table size) - uses binder #f #f #f #f #f + uses binder #f %pre-modules-transformer + #f #f #f (make-hash-table %default-import-size) '() (make-weak-key-hash-table 31)))) @@ -1219,7 +1327,7 @@ (define module-transformer (record-accessor module-type 'transformer)) (define set-module-transformer! (record-modifier module-type 'transformer)) -(define module-name (record-accessor module-type 'name)) +;; (define module-name (record-accessor module-type 'name)) wait until mods are booted (define set-module-name! (record-modifier module-type 'name)) (define module-kind (record-accessor module-type 'kind)) (define set-module-kind! (record-modifier module-type 'kind)) @@ -1363,7 +1471,9 @@ ;; or its uses? ;; (define (module-bound? m v) - (module-search module-locally-bound? m v)) + (let ((var (module-variable m v))) + (and var + (variable-bound? var)))) ;;; {Is a symbol interned in a module?} ;;; @@ -1799,7 +1909,7 @@ val (let ((m (make-module 31))) (set-module-kind! m 'directory) - (set-module-name! m (append (or (module-name module) '()) + (set-module-name! m (append (module-name module) (list (car name)))) (module-define! module (car name) m) m))) @@ -1853,22 +1963,31 @@ (define default-duplicate-binding-procedures #f) (define %app (make-module 31)) +(set-module-name! %app '(%app)) (define app %app) ;; for backwards compatability -(local-define '(%app modules) (make-module 31)) +(let ((m (make-module 31))) + (set-module-name! m '()) + (local-define '(%app modules) m)) (local-define '(%app modules guile) the-root-module) ;; This boots the module system. All bindings needed by modules.c ;; must have been defined by now. ;; (set-current-module the-root-module) +;; definition deferred for syncase's benefit. +(define module-name + (let ((accessor (record-accessor module-type 'name))) + (lambda (mod) + (or (accessor mod) + (begin + (set-module-name! mod (list (gensym))) + (accessor mod)))))) ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) (define (try-load-module name) - (or (begin-deprecated (try-module-linked name)) - (try-module-autoload name) - (begin-deprecated (try-module-dynamic-link name)))) + (try-module-autoload name)) (define (purify-module! module) "Removes bindings in MODULE which are inherited from the (guile) module." @@ -2002,23 +2121,34 @@ ((#:use-module #:use-syntax) (or (pair? (cdr kws)) (unrecognized kws)) - (let* ((interface-args (cadr kws)) - (interface (apply resolve-interface interface-args))) - (and (eq? (car kws) #:use-syntax) - (or (symbol? (caar interface-args)) - (error "invalid module name for use-syntax" - (car interface-args))) - (set-module-transformer! - module - (module-ref interface - (car (last-pair (car interface-args))) - #f))) + (cond + ((equal? (caadr kws) '(ice-9 syncase)) + (issue-deprecation-warning + "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.") (loop (cddr kws) - (cons interface reversed-interfaces) + reversed-interfaces exports re-exports replacements - autoloads))) + autoloads)) + (else + (let* ((interface-args (cadr kws)) + (interface (apply resolve-interface interface-args))) + (and (eq? (car kws) #:use-syntax) + (or (symbol? (caar interface-args)) + (error "invalid module name for use-syntax" + (car interface-args))) + (set-module-transformer! + module + (module-ref interface + (car (last-pair (car interface-args))) + #f))) + (loop (cddr kws) + (cons interface reversed-interfaces) + exports + re-exports + replacements + autoloads))))) ((#:autoload) (or (and (pair? (cdr kws)) (pair? (cddr kws))) (unrecognized kws)) @@ -2310,11 +2440,12 @@ module '(ice-9 q) '(make-q q-length))}." (define (set-repl-prompt! v) (set! scm-repl-prompt v)) (define (default-pre-unwind-handler key . args) - (save-stack pre-unwind-handler-dispatch) + (save-stack 1) (apply throw key args)) -(define (pre-unwind-handler-dispatch key . args) - (apply default-pre-unwind-handler key args)) +(begin-deprecated + (define (pre-unwind-handler-dispatch key . args) + (apply default-pre-unwind-handler key args))) (define abort-hook (make-hook)) @@ -2391,15 +2522,7 @@ module '(ice-9 q) '(make-q q-length))}." (else (apply bad-throw key args))))))) - ;; Note that having just `pre-unwind-handler-dispatch' - ;; here is connected with the mechanism that - ;; produces a nice backtrace upon error. If, for - ;; example, this is replaced with (lambda args - ;; (apply pre-unwind-handler-dispatch args)), the stack - ;; cutting (in save-stack) goes wrong and ends up - ;; saving no stack at all, so there is no - ;; backtrace. - pre-unwind-handler-dispatch))) + default-pre-unwind-handler))) (if next (loop next) status))) (set! set-batch-mode?! (lambda (arg) @@ -2674,32 +2797,6 @@ module '(ice-9 q) '(make-q q-length))}." `(with-fluids* (list ,@fluids) (list ,@values) (lambda () ,@body))))) - - -;;; {Macros} -;;; - -;; actually....hobbit might be able to hack these with a little -;; coaxing -;; - -(define (primitive-macro? m) - (and (macro? m) - (not (macro-transformer m)))) - -(defmacro define-macro (first . rest) - (let ((name (if (symbol? first) first (car first))) - (transformer - (if (symbol? first) - (car rest) - `(lambda ,(cdr first) ,@rest)))) - `(eval-when - (eval load compile) - (define ,name (defmacro:transformer ,transformer))))) - - - - ;;; {While} ;;; ;;; with `continue' and `break'. @@ -2839,50 +2936,33 @@ module '(ice-9 q) '(make-q q-length))}." (defmacro use-syntax (spec) `(eval-when (eval load compile) - ,@(if (pair? spec) - `((process-use-modules (list - (list ,@(compile-interface-spec spec)))) - (set-module-transformer! (current-module) - ,(car (last-pair spec)))) - `((set-module-transformer! (current-module) ,spec))) - *unspecified*)) + (issue-deprecation-warning + "`use-syntax' is deprecated. Please contact guile-devel for more info.") + (process-use-modules (list (list ,@(compile-interface-spec spec)))) + *unspecified*)) ;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed ;; as soon as guile supports hygienic macros. -(define define-private define) +(define-syntax define-private + (syntax-rules () + ((_ foo bar) + (define foo bar)))) -(defmacro define-public args - (define (syntax) - (error "bad syntax" (list 'define-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - ((pair? n) (defined-name (car n))) - (else (syntax)))) - (cond - ((null? args) - (syntax)) - (#t - (let ((name (defined-name (car args)))) - `(begin - (define-private ,@args) - (export ,name)))))) +(define-syntax define-public + (syntax-rules () + ((_ (name . args) . body) + (define-public name (lambda args . body))) + ((_ name val) + (begin + (define name val) + (export name))))) -(defmacro defmacro-public args - (define (syntax) - (error "bad syntax" (list 'defmacro-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - (else (syntax)))) - (cond - ((null? args) - (syntax)) - (#t - (let ((name (defined-name (car args)))) - `(begin - (export-syntax ,name) - (defmacro ,@args)))))) +(define-syntax defmacro-public + (syntax-rules () + ((_ name args . body) + (begin + (defmacro name args . body) + (export-syntax name))))) ;; Export a local variable @@ -2936,19 +3016,6 @@ module '(ice-9 q) '(make-q q-length))}." (define load load-module) - - -;;; {Compiler interface} -;;; -;;; The full compiler interface can be found in (system). Here we put a -;;; few useful procedures into the global namespace. - -(module-autoload! the-scm-module - '(system base compile) - '(compile - compile-time-environment)) - - ;;; {Parameters} @@ -3371,6 +3438,13 @@ module '(ice-9 q) '(make-q q-length))}." ;;; Place the user in the guile-user module. ;;; -(define-module (guile-user)) +;;; FIXME: annotate ? +;; (define (syncase exp) +;; (with-fluids ((expansion-eval-closure +;; (module-eval-closure (current-module)))) +;; (deannotate/source-properties (sc-expand (annotate exp))))) + +(define-module (guile-user) + #:autoload (system base compile) (compile)) ;;; boot-9.scm ends here diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 10a307be1..2b8eec0d2 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -1,27 +1,20 @@ -(use-modules (ice-9 syncase)) - -;; XXX - We need to be inside (ice-9 syncase) since psyntax.ss calls -;; `eval' int he `interaction-environment' aka the current module and -;; it expects to have `andmap' there. The reason for this escapes me -;; at the moment. -;; -(define-module (ice-9 syncase)) - -(define source (list-ref (command-line) 1)) -(define target (list-ref (command-line) 2)) - -(let ((in (open-input-file source)) - (out (open-output-file (string-append target ".tmp")))) - (let loop ((x (read in))) - (if (eof-object? x) - (begin - (close-port out) - (close-port in)) - (begin - (write (strip-expansion-structures - (sc-expand3 x 'c '(compile load eval))) - out) - (newline out) - (loop (read in)))))) - -(system (format #f "mv -f ~s.tmp ~s" target target)) +(use-modules (language tree-il)) +(let ((source (list-ref (command-line) 1)) + (target (list-ref (command-line) 2))) + (let ((in (open-input-file source)) + (out (open-output-file (string-append target ".tmp")))) + (write '(eval-when (compile) (set-current-module (resolve-module '(guile)))) + out) + (newline out) + (let loop ((x (read in))) + (if (eof-object? x) + (begin + (close-port out) + (close-port in)) + (begin + (write (tree-il->scheme + (sc-expand x 'c '(compile load eval))) + out) + (newline out) + (loop (read in)))))) + (system (format #f "mv -f ~s.tmp ~s" target target))) diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm index c5f447e78..92d31cabc 100644 --- a/module/ice-9/documentation.scm +++ b/module/ice-9/documentation.scm @@ -195,15 +195,11 @@ OBJECT can be a procedure, macro or any object that has its `documentation' property set." (or (and (procedure? object) (proc-doc object)) - (and (defmacro? object) - (proc-doc (defmacro-transformer object))) - (and (macro? object) - (let ((transformer (macro-transformer object))) - (and transformer - (proc-doc transformer)))) (object-property object 'documentation) (and (program? object) (program-documentation object)) + (and (macro? object) + (object-documentation (macro-transformer object))) (and (procedure? object) (not (closure? object)) (procedure-name object) diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm deleted file mode 100644 index 372d959a5..000000000 --- a/module/ice-9/expand-support.scm +++ /dev/null @@ -1,169 +0,0 @@ -;;;; Copyright (C) 2009 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2.1 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 expand-support) - :export ( annotation? annotate deannotate make-annotation - annotation-expression annotation-source annotation-stripped - set-annotation-stripped! - deannotate/source-properties - - make-module-ref - module-ref-symbol module-ref-modname module-ref-public? - - make-lexical - lexical-name lexical-gensym - - strip-expansion-structures)) - -(define - (make-vtable "prprpw" - (lambda (struct port) - (display "#" port)))) - -(define (annotation? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-annotation e s . stripped?) - (if (null? stripped?) - (make-struct 0 e s #f) - (apply make-struct 0 e s stripped?))) - -(define (annotation-expression a) - (struct-ref a 0)) -(define (annotation-source a) - (struct-ref a 1)) -(define (annotation-stripped a) - (struct-ref a 2)) -(define (set-annotation-stripped! a stripped?) - (struct-set! a 2 stripped?)) - -(define (annotate e) - (let ((p (if (pair? e) (source-properties e) #f)) - (out (cond ((and (list? e) (not (null? e))) - (map annotate e)) - ((pair? e) - (cons (annotate (car e)) (annotate (cdr e)))) - (else e)))) - (if (pair? p) - (make-annotation out p #f) - out))) - -(define (deannotate e) - (cond ((list? e) - (map deannotate e)) - ((pair? e) - (cons (deannotate (car e)) (deannotate (cdr e)))) - ((annotation? e) (deannotate (annotation-expression e))) - (else e))) - -(define (deannotate/source-properties e) - (cond ((list? e) - (map deannotate/source-properties e)) - ((pair? e) - (cons (deannotate/source-properties (car e)) - (deannotate/source-properties (cdr e)))) - ((annotation? e) - (let ((e (deannotate/source-properties (annotation-expression e))) - (source (annotation-source e))) - (if (pair? e) - (set-source-properties! e source)) - e)) - (else e))) - - - -(define - (make-vtable "prprpr" - (lambda (struct port) - (display "#<" port) - (display (if (module-ref-public? struct) "@ " "@@ ") port) - (display (module-ref-modname struct) port) - (display " " port) - (display (module-ref-symbol struct) port) - (display ">" port)))) - -(define (module-ref? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-module-ref modname symbol public?) - (make-struct 0 modname symbol public?)) - -(define (module-ref-modname a) - (struct-ref a 0)) -(define (module-ref-symbol a) - (struct-ref a 1)) -(define (module-ref-public? a) - (struct-ref a 2)) - - - -(define - (make-vtable "prpr" - (lambda (struct port) - (display "#" port)))) - -(define (lexical? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-lexical name gensym) - (make-struct 0 name gensym)) - -(define (lexical-name a) - (struct-ref a 0)) -(define (lexical-gensym a) - (struct-ref a 1)) - - - -(define (strip-expansion-structures e) - (cond ((list? e) - (map strip-expansion-structures e)) - ((pair? e) - (cons (strip-expansion-structures (car e)) - (strip-expansion-structures (cdr e)))) - ((annotation? e) - (let ((e (strip-expansion-structures (annotation-expression e))) - (source (annotation-source e))) - (if (pair? e) - (set-source-properties! e source)) - e)) - ((module-ref? e) - (cond - ((or (not (module-ref-modname e)) - (eq? (module-ref-modname e) - (module-name (current-module))) - (and (not (module-ref-public? e)) - (not (module-variable - (resolve-module (module-ref-modname e)) - (module-ref-symbol e))))) - (module-ref-symbol e)) - (else - `(,(if (module-ref-public? e) '@ '@@) - ,(module-ref-modname e) - ,(module-ref-symbol e))))) - ((lexical? e) - (lexical-gensym e)) - ((record? e) - (error "unexpected record in expansion" e)) - (else e))) diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm index e6fe56063..baa4d5aad 100644 --- a/module/ice-9/match.scm +++ b/module/ice-9/match.scm @@ -194,6 +194,6 @@ (define match:runtime-structures #f) (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v))) (define match:primitive-vector? vector?) -(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) +(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311)))) -(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) +(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) diff --git a/module/ice-9/networking.scm b/module/ice-9/networking.scm index c0218821f..9a30fc5b6 100644 --- a/module/ice-9/networking.scm +++ b/module/ice-9/networking.scm @@ -17,6 +17,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (define (gethostbyaddr addr) (gethost addr)) (define (gethostbyname name) (gethost name)) diff --git a/module/ice-9/null.scm b/module/ice-9/null.scm index b9212e605..3f9f5b0a5 100644 --- a/module/ice-9/null.scm +++ b/module/ice-9/null.scm @@ -18,7 +18,6 @@ ;;;; The null environment - only syntactic bindings (define-module (ice-9 null) - :use-module (ice-9 syncase) :re-export-syntax (define quote lambda if set! cond case and or diff --git a/module/ice-9/occam-channel.scm b/module/ice-9/occam-channel.scm index e28f73d3b..e04ecac5b 100644 --- a/module/ice-9/occam-channel.scm +++ b/module/ice-9/occam-channel.scm @@ -17,7 +17,6 @@ ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 occam-channel) - #:use-syntax (ice-9 syncase) #:use-module (oop goops) #:use-module (ice-9 threads) #:export-syntax (alt diff --git a/module/ice-9/posix.scm b/module/ice-9/posix.scm index 53d01a026..dd1a12690 100644 --- a/module/ice-9/posix.scm +++ b/module/ice-9/posix.scm @@ -17,6 +17,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (define (stat:dev f) (vector-ref f 0)) (define (stat:ino f) (vector-ref f 1)) (define (stat:mode f) (vector-ref f 2)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 02d9e9975..f33f49286 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,13 @@ -(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-544) (let syntmp-lvl-545 ((syntmp-vars-546 syntmp-vars-544) (syntmp-ls-547 (quote ())) (syntmp-w-548 (quote (())))) (cond ((pair? syntmp-vars-546) (syntmp-lvl-545 (cdr syntmp-vars-546) (cons (syntmp-wrap-132 (car syntmp-vars-546) syntmp-w-548 #f) syntmp-ls-547) syntmp-w-548)) ((syntmp-id?-104 syntmp-vars-546) (cons (syntmp-wrap-132 syntmp-vars-546 syntmp-w-548 #f) syntmp-ls-547)) ((null? syntmp-vars-546) syntmp-ls-547) ((syntmp-syntax-object?-88 syntmp-vars-546) (syntmp-lvl-545 (syntmp-syntax-object-expression-89 syntmp-vars-546) syntmp-ls-547 (syntmp-join-wraps-123 syntmp-w-548 (syntmp-syntax-object-wrap-90 syntmp-vars-546)))) ((annotation? syntmp-vars-546) (syntmp-lvl-545 (annotation-expression syntmp-vars-546) syntmp-ls-547 syntmp-w-548)) (else (cons syntmp-vars-546 syntmp-ls-547)))))) (syntmp-gen-var-152 (lambda (syntmp-id-549) (let ((syntmp-id-550 (if (syntmp-syntax-object?-88 syntmp-id-549) (syntmp-syntax-object-expression-89 syntmp-id-549) syntmp-id-549))) (if (annotation? syntmp-id-550) (syntmp-build-annotated-81 (annotation-source syntmp-id-550) (gensym (symbol->string (annotation-expression syntmp-id-550)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-550))))))) (syntmp-strip-151 (lambda (syntmp-x-551 syntmp-w-552) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-552)) (if (or (annotation? syntmp-x-551) (and (pair? syntmp-x-551) (annotation? (car syntmp-x-551)))) (syntmp-strip-annotation-150 syntmp-x-551 #f) syntmp-x-551) (let syntmp-f-553 ((syntmp-x-554 syntmp-x-551)) (cond ((syntmp-syntax-object?-88 syntmp-x-554) (syntmp-strip-151 (syntmp-syntax-object-expression-89 syntmp-x-554) (syntmp-syntax-object-wrap-90 syntmp-x-554))) ((pair? syntmp-x-554) (let ((syntmp-a-555 (syntmp-f-553 (car syntmp-x-554))) (syntmp-d-556 (syntmp-f-553 (cdr syntmp-x-554)))) (if (and (eq? syntmp-a-555 (car syntmp-x-554)) (eq? syntmp-d-556 (cdr syntmp-x-554))) syntmp-x-554 (cons syntmp-a-555 syntmp-d-556)))) ((vector? syntmp-x-554) (let ((syntmp-old-557 (vector->list syntmp-x-554))) (let ((syntmp-new-558 (map syntmp-f-553 syntmp-old-557))) (if (andmap eq? syntmp-old-557 syntmp-new-558) syntmp-x-554 (list->vector syntmp-new-558))))) (else syntmp-x-554)))))) (syntmp-strip-annotation-150 (lambda (syntmp-x-559 syntmp-parent-560) (cond ((pair? syntmp-x-559) (let ((syntmp-new-561 (cons #f #f))) (begin (if syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-561)) (set-car! syntmp-new-561 (syntmp-strip-annotation-150 (car syntmp-x-559) #f)) (set-cdr! syntmp-new-561 (syntmp-strip-annotation-150 (cdr syntmp-x-559) #f)) syntmp-new-561))) ((annotation? syntmp-x-559) (or (annotation-stripped syntmp-x-559) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-559) syntmp-x-559))) ((vector? syntmp-x-559) (let ((syntmp-new-562 (make-vector (vector-length syntmp-x-559)))) (begin (if syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-562)) (let syntmp-loop-563 ((syntmp-i-564 (- (vector-length syntmp-x-559) 1))) (unless (syntmp-fx<-75 syntmp-i-564 0) (vector-set! syntmp-new-562 syntmp-i-564 (syntmp-strip-annotation-150 (vector-ref syntmp-x-559 syntmp-i-564) #f)) (syntmp-loop-563 (syntmp-fx--73 syntmp-i-564 1)))) syntmp-new-562))) (else syntmp-x-559)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-565) (and (syntmp-nonsymbol-id?-103 syntmp-x-565) (syntmp-free-id=?-127 syntmp-x-565 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-566 syntmp-mod-567) (let ((syntmp-p-568 (syntmp-local-eval-hook-77 syntmp-expanded-566 syntmp-mod-567))) (if (procedure? syntmp-p-568) syntmp-p-568 (syntax-error syntmp-p-568 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146 (lambda (syntmp-rec?-569 syntmp-e-570 syntmp-r-571 syntmp-w-572 syntmp-s-573 syntmp-mod-574 syntmp-k-575) ((lambda (syntmp-tmp-576) ((lambda (syntmp-tmp-577) (if syntmp-tmp-577 (apply (lambda (syntmp-_-578 syntmp-id-579 syntmp-val-580 syntmp-e1-581 syntmp-e2-582) (let ((syntmp-ids-583 syntmp-id-579)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-583)) (syntax-error syntmp-e-570 "duplicate bound keyword in") (let ((syntmp-labels-585 (syntmp-gen-labels-110 syntmp-ids-583))) (let ((syntmp-new-w-586 (syntmp-make-binding-wrap-121 syntmp-ids-583 syntmp-labels-585 syntmp-w-572))) (syntmp-k-575 (cons syntmp-e1-581 syntmp-e2-582) (syntmp-extend-env-98 syntmp-labels-585 (let ((syntmp-w-588 (if syntmp-rec?-569 syntmp-new-w-586 syntmp-w-572)) (syntmp-trans-r-589 (syntmp-macros-only-env-100 syntmp-r-571))) (map (lambda (syntmp-x-590) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-590 syntmp-trans-r-589 syntmp-w-588 syntmp-mod-574) syntmp-mod-574))) syntmp-val-580)) syntmp-r-571) syntmp-new-w-586 syntmp-s-573 syntmp-mod-574)))))) syntmp-tmp-577) ((lambda (syntmp-_-592) (syntax-error (syntmp-source-wrap-133 syntmp-e-570 syntmp-w-572 syntmp-s-573 syntmp-mod-574))) syntmp-tmp-576))) (syntax-dispatch syntmp-tmp-576 (quote (any #(each (any any)) any . each-any))))) syntmp-e-570))) (syntmp-chi-lambda-clause-145 (lambda (syntmp-e-593 syntmp-c-594 syntmp-r-595 syntmp-w-596 syntmp-mod-597 syntmp-k-598) ((lambda (syntmp-tmp-599) ((lambda (syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-id-601 syntmp-e1-602 syntmp-e2-603) (let ((syntmp-ids-604 syntmp-id-601)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-604)) (syntax-error syntmp-e-593 "invalid parameter list in") (let ((syntmp-labels-606 (syntmp-gen-labels-110 syntmp-ids-604)) (syntmp-new-vars-607 (map syntmp-gen-var-152 syntmp-ids-604))) (syntmp-k-598 syntmp-new-vars-607 (syntmp-chi-body-144 (cons syntmp-e1-602 syntmp-e2-603) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-606 syntmp-new-vars-607 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-ids-604 syntmp-labels-606 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-600) ((lambda (syntmp-tmp-609) (if syntmp-tmp-609 (apply (lambda (syntmp-ids-610 syntmp-e1-611 syntmp-e2-612) (let ((syntmp-old-ids-613 (syntmp-lambda-var-list-153 syntmp-ids-610))) (if (not (syntmp-valid-bound-ids?-129 syntmp-old-ids-613)) (syntax-error syntmp-e-593 "invalid parameter list in") (let ((syntmp-labels-614 (syntmp-gen-labels-110 syntmp-old-ids-613)) (syntmp-new-vars-615 (map syntmp-gen-var-152 syntmp-old-ids-613))) (syntmp-k-598 (let syntmp-f-616 ((syntmp-ls1-617 (cdr syntmp-new-vars-615)) (syntmp-ls2-618 (car syntmp-new-vars-615))) (if (null? syntmp-ls1-617) syntmp-ls2-618 (syntmp-f-616 (cdr syntmp-ls1-617) (cons (car syntmp-ls1-617) syntmp-ls2-618)))) (syntmp-chi-body-144 (cons syntmp-e1-611 syntmp-e2-612) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-614 syntmp-new-vars-615 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-old-ids-613 syntmp-labels-614 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-609) ((lambda (syntmp-_-620) (syntax-error syntmp-e-593)) syntmp-tmp-599))) (syntax-dispatch syntmp-tmp-599 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-599 (quote (each-any any . each-any))))) syntmp-c-594))) (syntmp-chi-body-144 (lambda (syntmp-body-621 syntmp-outer-form-622 syntmp-r-623 syntmp-w-624 syntmp-mod-625) (let ((syntmp-r-626 (cons (quote ("placeholder" placeholder)) syntmp-r-623))) (let ((syntmp-ribcage-627 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-628 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-624) (cons syntmp-ribcage-627 (syntmp-wrap-subst-108 syntmp-w-624))))) (let syntmp-parse-629 ((syntmp-body-630 (map (lambda (syntmp-x-636) (cons syntmp-r-626 (syntmp-wrap-132 syntmp-x-636 syntmp-w-628 syntmp-mod-625))) syntmp-body-621)) (syntmp-ids-631 (quote ())) (syntmp-labels-632 (quote ())) (syntmp-vars-633 (quote ())) (syntmp-vals-634 (quote ())) (syntmp-bindings-635 (quote ()))) (if (null? syntmp-body-630) (syntax-error syntmp-outer-form-622 "no expressions in body") (let ((syntmp-e-637 (cdar syntmp-body-630)) (syntmp-er-638 (caar syntmp-body-630))) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-637 syntmp-er-638 (quote (())) #f syntmp-ribcage-627 syntmp-mod-625)) (lambda (syntmp-type-639 syntmp-value-640 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644) (let ((syntmp-t-645 syntmp-type-639)) (if (memv syntmp-t-645 (quote (define-form))) (let ((syntmp-id-646 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644)) (syntmp-label-647 (syntmp-gen-label-109))) (let ((syntmp-var-648 (syntmp-gen-var-152 syntmp-id-646))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-646 syntmp-label-647) (syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-646 syntmp-ids-631) (cons syntmp-label-647 syntmp-labels-632) (cons syntmp-var-648 syntmp-vars-633) (cons (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644)) syntmp-vals-634) (cons (cons (quote lexical) syntmp-var-648) syntmp-bindings-635))))) (if (memv syntmp-t-645 (quote (define-syntax-form))) (let ((syntmp-id-649 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644)) (syntmp-label-650 (syntmp-gen-label-109))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-649 syntmp-label-650) (syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-649 syntmp-ids-631) (cons syntmp-label-650 syntmp-labels-632) syntmp-vars-633 syntmp-vals-634 (cons (cons (quote macro) (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644))) syntmp-bindings-635)))) (if (memv syntmp-t-645 (quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-629 (let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null? syntmp-forms-656) (cdr syntmp-body-630) (cons (cons syntmp-er-638 (syntmp-wrap-132 (car syntmp-forms-656) syntmp-w-642 syntmp-mod-644)) (syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635)) syntmp-tmp-652) (syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any . each-any))))) syntmp-e-641) (if (memv syntmp-t-645 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-640 syntmp-e-641 syntmp-er-638 syntmp-w-642 syntmp-s-643 syntmp-mod-644 (lambda (syntmp-forms-658 syntmp-er-659 syntmp-w-660 syntmp-s-661 syntmp-mod-662) (syntmp-parse-629 (let syntmp-f-663 ((syntmp-forms-664 syntmp-forms-658)) (if (null? syntmp-forms-664) (cdr syntmp-body-630) (cons (cons syntmp-er-659 (syntmp-wrap-132 (car syntmp-forms-664) syntmp-w-660 syntmp-mod-662)) (syntmp-f-663 (cdr syntmp-forms-664))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635))) (if (null? syntmp-ids-631) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-665) (syntmp-chi-140 (cdr syntmp-x-665) (car syntmp-x-665) (quote (())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr syntmp-body-630)))) (begin (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-631)) (syntax-error syntmp-outer-form-622 "invalid or duplicate identifier in definition")) (let syntmp-loop-666 ((syntmp-bs-667 syntmp-bindings-635) (syntmp-er-cache-668 #f) (syntmp-r-cache-669 #f)) (if (not (null? syntmp-bs-667)) (let ((syntmp-b-670 (car syntmp-bs-667))) (if (eq? (car syntmp-b-670) (quote macro)) (let ((syntmp-er-671 (cadr syntmp-b-670))) (let ((syntmp-r-cache-672 (if (eq? syntmp-er-671 syntmp-er-cache-668) syntmp-r-cache-669 (syntmp-macros-only-env-100 syntmp-er-671)))) (begin (set-cdr! syntmp-b-670 (syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-670) syntmp-r-cache-672 (quote (())) syntmp-mod-644) syntmp-mod-644)) (syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-671 syntmp-r-cache-672)))) (syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-cache-668 syntmp-r-cache-669))))) (set-cdr! syntmp-r-626 (syntmp-extend-env-98 syntmp-labels-632 syntmp-bindings-635 (cdr syntmp-r-626))) (syntmp-build-letrec-86 #f syntmp-vars-633 (map (lambda (syntmp-x-673) (syntmp-chi-140 (cdr syntmp-x-673) (car syntmp-x-673) (quote (())) syntmp-mod-644)) syntmp-vals-634) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-674) (syntmp-chi-140 (cdr syntmp-x-674) (car syntmp-x-674) (quote (())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr syntmp-body-630)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda (syntmp-p-675 syntmp-e-676 syntmp-r-677 syntmp-w-678 syntmp-rib-679 syntmp-mod-680) (letrec ((syntmp-rebuild-macro-output-681 (lambda (syntmp-x-682 syntmp-m-683) (cond ((pair? syntmp-x-682) (cons (syntmp-rebuild-macro-output-681 (car syntmp-x-682) syntmp-m-683) (syntmp-rebuild-macro-output-681 (cdr syntmp-x-682) syntmp-m-683))) ((syntmp-syntax-object?-88 syntmp-x-682) (let ((syntmp-w-684 (syntmp-syntax-object-wrap-90 syntmp-x-682))) (let ((syntmp-ms-685 (syntmp-wrap-marks-107 syntmp-w-684)) (syntmp-s-686 (syntmp-wrap-subst-108 syntmp-w-684))) (if (and (pair? syntmp-ms-685) (eq? (car syntmp-ms-685) #f)) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cdr syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cdr syntmp-s-686)) (cdr syntmp-s-686))) (syntmp-syntax-object-module-91 syntmp-x-682)) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cons syntmp-m-683 syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cons (quote shift) syntmp-s-686)) (cons (quote shift) syntmp-s-686))) (module-name (procedure-module syntmp-p-675))))))) ((vector? syntmp-x-682) (let ((syntmp-n-687 (vector-length syntmp-x-682))) (let ((syntmp-v-688 (make-vector syntmp-n-687))) (let syntmp-doloop-689 ((syntmp-i-690 0)) (if (syntmp-fx=-74 syntmp-i-690 syntmp-n-687) syntmp-v-688 (begin (vector-set! syntmp-v-688 syntmp-i-690 (syntmp-rebuild-macro-output-681 (vector-ref syntmp-x-682 syntmp-i-690) syntmp-m-683)) (syntmp-doloop-689 (syntmp-fx+-72 syntmp-i-690 1)))))))) ((symbol? syntmp-x-682) (syntax-error syntmp-x-682 "encountered raw symbol in macro output")) (else syntmp-x-682))))) (syntmp-rebuild-macro-output-681 (syntmp-p-675 (syntmp-wrap-132 syntmp-e-676 (syntmp-anti-mark-119 syntmp-w-678) syntmp-mod-680)) (string #\m))))) (syntmp-chi-application-142 (lambda (syntmp-x-691 syntmp-e-692 syntmp-r-693 syntmp-w-694 syntmp-s-695 syntmp-mod-696) ((lambda (syntmp-tmp-697) ((lambda (syntmp-tmp-698) (if syntmp-tmp-698 (apply (lambda (syntmp-e0-699 syntmp-e1-700) (syntmp-build-annotated-81 syntmp-s-695 (cons syntmp-x-691 (map (lambda (syntmp-e-701) (syntmp-chi-140 syntmp-e-701 syntmp-r-693 syntmp-w-694 syntmp-mod-696)) syntmp-e1-700)))) syntmp-tmp-698) (syntax-error syntmp-tmp-697))) (syntax-dispatch syntmp-tmp-697 (quote (any . each-any))))) syntmp-e-692))) (syntmp-chi-expr-141 (lambda (syntmp-type-703 syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (let ((syntmp-t-710 syntmp-type-703)) (if (memv syntmp-t-710 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-708 syntmp-value-704) (if (memv syntmp-t-710 (quote (core external-macro))) (syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-704 syntmp-e-705)) (lambda (syntmp-id-711 syntmp-mod-712) (syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-712 syntmp-id-711 #f)))) (if (memv syntmp-t-710 (quote (lexical-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-705)) syntmp-value-704) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-705)) (make-module-ref (if (syntmp-syntax-object?-88 (car syntmp-e-705)) (syntmp-syntax-object-module-91 (car syntmp-e-705)) syntmp-mod-709) syntmp-value-704 #f)) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (constant))) (syntmp-build-data-82 syntmp-s-708 (syntmp-strip-151 (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (quote (())))) (if (memv syntmp-t-710 (quote (global))) (syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-709 syntmp-value-704 #f)) (if (memv syntmp-t-710 (quote (call))) (syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-705) syntmp-r-706 syntmp-w-707 syntmp-mod-709) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (begin-form))) ((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply (lambda (syntmp-_-715 syntmp-e1-716 syntmp-e2-717) (syntmp-chi-sequence-134 (cons syntmp-e1-716 syntmp-e2-717) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709)) syntmp-tmp-714) (syntax-error syntmp-tmp-713))) (syntax-dispatch syntmp-tmp-713 (quote (any any . each-any))))) syntmp-e-705) (if (memv syntmp-t-710 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709 syntmp-chi-sequence-134) (if (memv syntmp-t-710 (quote (eval-when-form))) ((lambda (syntmp-tmp-719) ((lambda (syntmp-tmp-720) (if syntmp-tmp-720 (apply (lambda (syntmp-_-721 syntmp-x-722 syntmp-e1-723 syntmp-e2-724) (let ((syntmp-when-list-725 (syntmp-chi-when-list-137 syntmp-e-705 syntmp-x-722 syntmp-w-707))) (if (memq (quote eval) syntmp-when-list-725) (syntmp-chi-sequence-134 (cons syntmp-e1-723 syntmp-e2-724) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (syntmp-chi-void-148)))) syntmp-tmp-720) (syntax-error syntmp-tmp-719))) (syntax-dispatch syntmp-tmp-719 (quote (any each-any any . each-any))))) syntmp-e-705) (if (memv syntmp-t-710 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-132 syntmp-value-704 syntmp-w-707 syntmp-mod-709) "invalid context for definition of") (if (memv syntmp-t-710 (quote (syntax))) (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to pattern variable outside syntax form") (if (memv syntmp-t-710 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709))))))))))))))))))) (syntmp-chi-140 (lambda (syntmp-e-728 syntmp-r-729 syntmp-w-730 syntmp-mod-731) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-728 syntmp-r-729 syntmp-w-730 #f #f syntmp-mod-731)) (lambda (syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-w-735 syntmp-s-736 syntmp-mod-737) (syntmp-chi-expr-141 syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-r-729 syntmp-w-735 syntmp-s-736 syntmp-mod-737))))) (syntmp-chi-top-139 (lambda (syntmp-e-738 syntmp-r-739 syntmp-w-740 syntmp-m-741 syntmp-esew-742 syntmp-mod-743) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-738 syntmp-r-739 syntmp-w-740 #f #f syntmp-mod-743)) (lambda (syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-w-761 syntmp-s-762 syntmp-mod-763) (let ((syntmp-t-764 syntmp-type-758)) (if (memv syntmp-t-764 (quote (begin-form))) ((lambda (syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda (syntmp-_-767) (syntmp-chi-void-148)) syntmp-tmp-766) ((lambda (syntmp-tmp-768) (if syntmp-tmp-768 (apply (lambda (syntmp-_-769 syntmp-e1-770 syntmp-e2-771) (syntmp-chi-top-sequence-135 (cons syntmp-e1-770 syntmp-e2-771) syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-m-741 syntmp-esew-742 syntmp-mod-763)) syntmp-tmp-768) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-765 (quote (any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-759 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-mod-763 (lambda (syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-mod-777) (syntmp-chi-top-sequence-135 syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-m-741 syntmp-esew-742 syntmp-mod-777))) (if (memv syntmp-t-764 (quote (eval-when-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-x-781 syntmp-e1-782 syntmp-e2-783) (let ((syntmp-when-list-784 (syntmp-chi-when-list-137 syntmp-e-760 syntmp-x-781 syntmp-w-761)) (syntmp-body-785 (cons syntmp-e1-782 syntmp-e2-783))) (cond ((eq? syntmp-m-741 (quote e)) (if (memq (quote eval) syntmp-when-list-784) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) (syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-784) (if (or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c&e) (quote (compile load)) syntmp-mod-763) (if (memq syntmp-m-741 (quote (c c&e))) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c) (quote (load)) syntmp-mod-763) (syntmp-chi-void-148)))) ((or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) syntmp-mod-763) (syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-779) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any each-any any . each-any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (define-syntax-form))) (let ((syntmp-n-788 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761)) (syntmp-r-789 (syntmp-macros-only-env-100 syntmp-r-739))) (let ((syntmp-t-790 syntmp-m-741)) (if (memv syntmp-t-790 (quote (c))) (if (memq (quote compile) syntmp-esew-742) (let ((syntmp-e-791 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-791 syntmp-mod-763) (if (memq (quote load) syntmp-esew-742) syntmp-e-791 (syntmp-chi-void-148)))) (if (memq (quote load) syntmp-esew-742) (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)) (syntmp-chi-void-148))) (if (memv syntmp-t-790 (quote (c&e))) (let ((syntmp-e-792 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-792 syntmp-mod-763) syntmp-e-792)) (begin (if (memq (quote eval) syntmp-esew-742) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)) syntmp-mod-763)) (syntmp-chi-void-148)))))) (if (memv syntmp-t-764 (quote (define-form))) (let ((syntmp-n-793 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761))) (let ((syntmp-type-794 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-793 syntmp-r-739 syntmp-mod-763)))) (let ((syntmp-t-795 syntmp-type-794)) (if (memv syntmp-t-795 (quote (global))) (let ((syntmp-x-796 (syntmp-build-annotated-81 syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-796 syntmp-mod-763)) syntmp-x-796)) (if (memv syntmp-t-795 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763) "identifier out of context") (if (eq? syntmp-type-794 (quote external-macro)) (let ((syntmp-x-797 (syntmp-build-annotated-81 syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-797 syntmp-mod-763)) syntmp-x-797)) (syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763) "cannot define keyword at top level"))))))) (let ((syntmp-x-798 (syntmp-chi-expr-141 syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-mod-763))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-798 syntmp-mod-763)) syntmp-x-798)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (cond ((symbol? syntmp-e-799) (let ((syntmp-n-805 (syntmp-id-var-name-126 syntmp-e-799 syntmp-w-801))) (let ((syntmp-b-806 (syntmp-lookup-101 syntmp-n-805 syntmp-r-800 syntmp-mod-804))) (let ((syntmp-type-807 (syntmp-binding-type-96 syntmp-b-806))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (lexical))) (values syntmp-type-807 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-808 (quote (global))) (values syntmp-type-807 syntmp-n-805 syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-808 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (values syntmp-type-807 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804))))))))) ((pair? syntmp-e-799) (let ((syntmp-first-809 (car syntmp-e-799))) (if (syntmp-id?-104 syntmp-first-809) (let ((syntmp-n-810 (syntmp-id-var-name-126 syntmp-first-809 syntmp-w-801))) (let ((syntmp-b-811 (syntmp-lookup-101 syntmp-n-810 syntmp-r-800 (or (and (syntmp-syntax-object?-88 syntmp-first-809) (syntmp-syntax-object-module-91 syntmp-first-809)) syntmp-mod-804)))) (let ((syntmp-type-812 (syntmp-binding-type-96 syntmp-b-811))) (let ((syntmp-t-813 syntmp-type-812)) (if (memv syntmp-t-813 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (global))) (values (quote global-call) syntmp-n-810 syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (if (memv syntmp-t-813 (quote (core external-macro module-ref))) (values syntmp-type-812 (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (begin))) (values (quote begin-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (define))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818) (syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda (syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-form) syntmp-name-820 syntmp-val-821 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) syntmp-tmp-815) ((lambda (syntmp-tmp-822) (if (if syntmp-tmp-822 (apply (lambda (syntmp-_-823 syntmp-name-824 syntmp-args-825 syntmp-e1-826 syntmp-e2-827) (and (syntmp-id?-104 syntmp-name-824) (syntmp-valid-bound-ids?-129 (syntmp-lambda-var-list-153 syntmp-args-825)))) syntmp-tmp-822) #f) (apply (lambda (syntmp-_-828 syntmp-name-829 syntmp-args-830 syntmp-e1-831 syntmp-e2-832) (values (quote define-form) (syntmp-wrap-132 syntmp-name-829 syntmp-w-801 syntmp-mod-804) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-132 (cons syntmp-args-830 (cons syntmp-e1-831 syntmp-e2-832)) syntmp-w-801 syntmp-mod-804)) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-822) ((lambda (syntmp-tmp-834) (if (if syntmp-tmp-834 (apply (lambda (syntmp-_-835 syntmp-name-836) (syntmp-id?-104 syntmp-name-836)) syntmp-tmp-834) #f) (apply (lambda (syntmp-_-837 syntmp-name-838) (values (quote define-form) (syntmp-wrap-132 syntmp-name-838 syntmp-w-801 syntmp-mod-804) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-834) (syntax-error syntmp-tmp-814))) (syntax-dispatch syntmp-tmp-814 (quote (any any)))))) (syntax-dispatch syntmp-tmp-814 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-814 (quote (any any any))))) syntmp-e-799) (if (memv syntmp-t-813 (quote (define-syntax))) ((lambda (syntmp-tmp-839) ((lambda (syntmp-tmp-840) (if (if syntmp-tmp-840 (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-val-843) (syntmp-id?-104 syntmp-name-842)) syntmp-tmp-840) #f) (apply (lambda (syntmp-_-844 syntmp-name-845 syntmp-val-846) (values (quote define-syntax-form) syntmp-name-845 syntmp-val-846 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) syntmp-tmp-840) (syntax-error syntmp-tmp-839))) (syntax-dispatch syntmp-tmp-839 (quote (any any any))))) syntmp-e-799) (values (quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))))))))))))) (values (quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))) ((syntmp-syntax-object?-88 syntmp-e-799) (syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-799) syntmp-r-800 (syntmp-join-wraps-123 syntmp-w-801 (syntmp-syntax-object-wrap-90 syntmp-e-799)) #f syntmp-rib-803 (or (syntmp-syntax-object-module-91 syntmp-e-799) syntmp-mod-804))) ((annotation? syntmp-e-799) (syntmp-syntax-type-138 (annotation-expression syntmp-e-799) syntmp-r-800 syntmp-w-801 (annotation-source syntmp-e-799) syntmp-rib-803 syntmp-mod-804)) ((self-evaluating? syntmp-e-799) (values (quote constant) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) (else (values (quote other) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804))))) (syntmp-chi-when-list-137 (lambda (syntmp-e-847 syntmp-when-list-848 syntmp-w-849) (let syntmp-f-850 ((syntmp-when-list-851 syntmp-when-list-848) (syntmp-situations-852 (quote ()))) (if (null? syntmp-when-list-851) syntmp-situations-852 (syntmp-f-850 (cdr syntmp-when-list-851) (cons (let ((syntmp-x-853 (car syntmp-when-list-851))) (cond ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-132 syntmp-x-853 syntmp-w-849 #f) "invalid eval-when situation")))) syntmp-situations-852)))))) (syntmp-chi-install-global-136 (lambda (syntmp-name-854 syntmp-e-855) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-854) syntmp-e-855)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-856 syntmp-r-857 syntmp-w-858 syntmp-s-859 syntmp-m-860 syntmp-esew-861 syntmp-mod-862) (syntmp-build-sequence-83 syntmp-s-859 (let syntmp-dobody-863 ((syntmp-body-864 syntmp-body-856) (syntmp-r-865 syntmp-r-857) (syntmp-w-866 syntmp-w-858) (syntmp-m-867 syntmp-m-860) (syntmp-esew-868 syntmp-esew-861) (syntmp-mod-869 syntmp-mod-862)) (if (null? syntmp-body-864) (quote ()) (let ((syntmp-first-870 (syntmp-chi-top-139 (car syntmp-body-864) syntmp-r-865 syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869))) (cons syntmp-first-870 (syntmp-dobody-863 (cdr syntmp-body-864) syntmp-r-865 syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869)))))))) (syntmp-chi-sequence-134 (lambda (syntmp-body-871 syntmp-r-872 syntmp-w-873 syntmp-s-874 syntmp-mod-875) (syntmp-build-sequence-83 syntmp-s-874 (let syntmp-dobody-876 ((syntmp-body-877 syntmp-body-871) (syntmp-r-878 syntmp-r-872) (syntmp-w-879 syntmp-w-873) (syntmp-mod-880 syntmp-mod-875)) (if (null? syntmp-body-877) (quote ()) (let ((syntmp-first-881 (syntmp-chi-140 (car syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880))) (cons syntmp-first-881 (syntmp-dobody-876 (cdr syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880)))))))) (syntmp-source-wrap-133 (lambda (syntmp-x-882 syntmp-w-883 syntmp-s-884 syntmp-defmod-885) (syntmp-wrap-132 (if syntmp-s-884 (make-annotation syntmp-x-882 syntmp-s-884 #f) syntmp-x-882) syntmp-w-883 syntmp-defmod-885))) (syntmp-wrap-132 (lambda (syntmp-x-886 syntmp-w-887 syntmp-defmod-888) (cond ((and (null? (syntmp-wrap-marks-107 syntmp-w-887)) (null? (syntmp-wrap-subst-108 syntmp-w-887))) syntmp-x-886) ((syntmp-syntax-object?-88 syntmp-x-886) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-886) (syntmp-join-wraps-123 syntmp-w-887 (syntmp-syntax-object-wrap-90 syntmp-x-886)) (syntmp-syntax-object-module-91 syntmp-x-886))) ((null? syntmp-x-886) syntmp-x-886) (else (syntmp-make-syntax-object-87 syntmp-x-886 syntmp-w-887 syntmp-defmod-888))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-889 syntmp-list-890) (and (not (null? syntmp-list-890)) (or (syntmp-bound-id=?-128 syntmp-x-889 (car syntmp-list-890)) (syntmp-bound-id-member?-131 syntmp-x-889 (cdr syntmp-list-890)))))) (syntmp-distinct-bound-ids?-130 (lambda (syntmp-ids-891) (let syntmp-distinct?-892 ((syntmp-ids-893 syntmp-ids-891)) (or (null? syntmp-ids-893) (and (not (syntmp-bound-id-member?-131 (car syntmp-ids-893) (cdr syntmp-ids-893))) (syntmp-distinct?-892 (cdr syntmp-ids-893))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-894) (and (let syntmp-all-ids?-895 ((syntmp-ids-896 syntmp-ids-894)) (or (null? syntmp-ids-896) (and (syntmp-id?-104 (car syntmp-ids-896)) (syntmp-all-ids?-895 (cdr syntmp-ids-896))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-894)))) (syntmp-bound-id=?-128 (lambda (syntmp-i-897 syntmp-j-898) (if (and (syntmp-syntax-object?-88 syntmp-i-897) (syntmp-syntax-object?-88 syntmp-j-898)) (and (eq? (let ((syntmp-e-899 (syntmp-syntax-object-expression-89 syntmp-i-897))) (if (annotation? syntmp-e-899) (annotation-expression syntmp-e-899) syntmp-e-899)) (let ((syntmp-e-900 (syntmp-syntax-object-expression-89 syntmp-j-898))) (if (annotation? syntmp-e-900) (annotation-expression syntmp-e-900) syntmp-e-900))) (syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-i-897)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-j-898)))) (eq? (let ((syntmp-e-901 syntmp-i-897)) (if (annotation? syntmp-e-901) (annotation-expression syntmp-e-901) syntmp-e-901)) (let ((syntmp-e-902 syntmp-j-898)) (if (annotation? syntmp-e-902) (annotation-expression syntmp-e-902) syntmp-e-902)))))) (syntmp-free-id=?-127 (lambda (syntmp-i-903 syntmp-j-904) (and (eq? (let ((syntmp-x-905 syntmp-i-903)) (let ((syntmp-e-906 (if (syntmp-syntax-object?-88 syntmp-x-905) (syntmp-syntax-object-expression-89 syntmp-x-905) syntmp-x-905))) (if (annotation? syntmp-e-906) (annotation-expression syntmp-e-906) syntmp-e-906))) (let ((syntmp-x-907 syntmp-j-904)) (let ((syntmp-e-908 (if (syntmp-syntax-object?-88 syntmp-x-907) (syntmp-syntax-object-expression-89 syntmp-x-907) syntmp-x-907))) (if (annotation? syntmp-e-908) (annotation-expression syntmp-e-908) syntmp-e-908)))) (eq? (syntmp-id-var-name-126 syntmp-i-903 (quote (()))) (syntmp-id-var-name-126 syntmp-j-904 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-909 syntmp-w-910) (letrec ((syntmp-search-vector-rib-913 (lambda (syntmp-sym-924 syntmp-subst-925 syntmp-marks-926 syntmp-symnames-927 syntmp-ribcage-928) (let ((syntmp-n-929 (vector-length syntmp-symnames-927))) (let syntmp-f-930 ((syntmp-i-931 0)) (cond ((syntmp-fx=-74 syntmp-i-931 syntmp-n-929) (syntmp-search-911 syntmp-sym-924 (cdr syntmp-subst-925) syntmp-marks-926)) ((and (eq? (vector-ref syntmp-symnames-927 syntmp-i-931) syntmp-sym-924) (syntmp-same-marks?-125 syntmp-marks-926 (vector-ref (syntmp-ribcage-marks-114 syntmp-ribcage-928) syntmp-i-931))) (values (vector-ref (syntmp-ribcage-labels-115 syntmp-ribcage-928) syntmp-i-931) syntmp-marks-926)) (else (syntmp-f-930 (syntmp-fx+-72 syntmp-i-931 1)))))))) (syntmp-search-list-rib-912 (lambda (syntmp-sym-932 syntmp-subst-933 syntmp-marks-934 syntmp-symnames-935 syntmp-ribcage-936) (let syntmp-f-937 ((syntmp-symnames-938 syntmp-symnames-935) (syntmp-i-939 0)) (cond ((null? syntmp-symnames-938) (syntmp-search-911 syntmp-sym-932 (cdr syntmp-subst-933) syntmp-marks-934)) ((and (eq? (car syntmp-symnames-938) syntmp-sym-932) (syntmp-same-marks?-125 syntmp-marks-934 (list-ref (syntmp-ribcage-marks-114 syntmp-ribcage-936) syntmp-i-939))) (values (list-ref (syntmp-ribcage-labels-115 syntmp-ribcage-936) syntmp-i-939) syntmp-marks-934)) (else (syntmp-f-937 (cdr syntmp-symnames-938) (syntmp-fx+-72 syntmp-i-939 1))))))) (syntmp-search-911 (lambda (syntmp-sym-940 syntmp-subst-941 syntmp-marks-942) (if (null? syntmp-subst-941) (values #f syntmp-marks-942) (let ((syntmp-fst-943 (car syntmp-subst-941))) (if (eq? syntmp-fst-943 (quote shift)) (syntmp-search-911 syntmp-sym-940 (cdr syntmp-subst-941) (cdr syntmp-marks-942)) (let ((syntmp-symnames-944 (syntmp-ribcage-symnames-113 syntmp-fst-943))) (if (vector? syntmp-symnames-944) (syntmp-search-vector-rib-913 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943) (syntmp-search-list-rib-912 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943))))))))) (cond ((symbol? syntmp-id-909) (or (call-with-values (lambda () (syntmp-search-911 syntmp-id-909 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-946 . syntmp-ignore-945) syntmp-x-946)) syntmp-id-909)) ((syntmp-syntax-object?-88 syntmp-id-909) (let ((syntmp-id-947 (let ((syntmp-e-949 (syntmp-syntax-object-expression-89 syntmp-id-909))) (if (annotation? syntmp-e-949) (annotation-expression syntmp-e-949) syntmp-e-949))) (syntmp-w1-948 (syntmp-syntax-object-wrap-90 syntmp-id-909))) (let ((syntmp-marks-950 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w1-948)))) (call-with-values (lambda () (syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w-910) syntmp-marks-950)) (lambda (syntmp-new-id-951 syntmp-marks-952) (or syntmp-new-id-951 (call-with-values (lambda () (syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w1-948) syntmp-marks-952)) (lambda (syntmp-x-954 . syntmp-ignore-953) syntmp-x-954)) syntmp-id-947)))))) ((annotation? syntmp-id-909) (let ((syntmp-id-955 (let ((syntmp-e-956 syntmp-id-909)) (if (annotation? syntmp-e-956) (annotation-expression syntmp-e-956) syntmp-e-956)))) (or (call-with-values (lambda () (syntmp-search-911 syntmp-id-955 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-958 . syntmp-ignore-957) syntmp-x-958)) syntmp-id-955))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-909)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-959 syntmp-y-960) (or (eq? syntmp-x-959 syntmp-y-960) (and (not (null? syntmp-x-959)) (not (null? syntmp-y-960)) (eq? (car syntmp-x-959) (car syntmp-y-960)) (syntmp-same-marks?-125 (cdr syntmp-x-959) (cdr syntmp-y-960)))))) (syntmp-join-marks-124 (lambda (syntmp-m1-961 syntmp-m2-962) (syntmp-smart-append-122 syntmp-m1-961 syntmp-m2-962))) (syntmp-join-wraps-123 (lambda (syntmp-w1-963 syntmp-w2-964) (let ((syntmp-m1-965 (syntmp-wrap-marks-107 syntmp-w1-963)) (syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w1-963))) (if (null? syntmp-m1-965) (if (null? syntmp-s1-966) syntmp-w2-964 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-964) (syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964)))) (syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-965 (syntmp-wrap-marks-107 syntmp-w2-964)) (syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964))))))) (syntmp-smart-append-122 (lambda (syntmp-m1-967 syntmp-m2-968) (if (null? syntmp-m2-968) syntmp-m1-967 (append syntmp-m1-967 syntmp-m2-968)))) (syntmp-make-binding-wrap-121 (lambda (syntmp-ids-969 syntmp-labels-970 syntmp-w-971) (if (null? syntmp-ids-969) syntmp-w-971 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-971) (cons (let ((syntmp-labelvec-972 (list->vector syntmp-labels-970))) (let ((syntmp-n-973 (vector-length syntmp-labelvec-972))) (let ((syntmp-symnamevec-974 (make-vector syntmp-n-973)) (syntmp-marksvec-975 (make-vector syntmp-n-973))) (begin (let syntmp-f-976 ((syntmp-ids-977 syntmp-ids-969) (syntmp-i-978 0)) (if (not (null? syntmp-ids-977)) (call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-977) syntmp-w-971)) (lambda (syntmp-symname-979 syntmp-marks-980) (begin (vector-set! syntmp-symnamevec-974 syntmp-i-978 syntmp-symname-979) (vector-set! syntmp-marksvec-975 syntmp-i-978 syntmp-marks-980) (syntmp-f-976 (cdr syntmp-ids-977) (syntmp-fx+-72 syntmp-i-978 1))))))) (syntmp-make-ribcage-111 syntmp-symnamevec-974 syntmp-marksvec-975 syntmp-labelvec-972))))) (syntmp-wrap-subst-108 syntmp-w-971)))))) (syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-981 syntmp-id-982 syntmp-label-983) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-981 (cons (let ((syntmp-e-984 (syntmp-syntax-object-expression-89 syntmp-id-982))) (if (annotation? syntmp-e-984) (annotation-expression syntmp-e-984) syntmp-e-984)) (syntmp-ribcage-symnames-113 syntmp-ribcage-981))) (syntmp-set-ribcage-marks!-117 syntmp-ribcage-981 (cons (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-id-982)) (syntmp-ribcage-marks-114 syntmp-ribcage-981))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-981 (cons syntmp-label-983 (syntmp-ribcage-labels-115 syntmp-ribcage-981)))))) (syntmp-anti-mark-119 (lambda (syntmp-w-985) (syntmp-make-wrap-106 (cons #f (syntmp-wrap-marks-107 syntmp-w-985)) (cons (quote shift) (syntmp-wrap-subst-108 syntmp-w-985))))) (syntmp-set-ribcage-labels!-118 (lambda (syntmp-x-986 syntmp-update-987) (vector-set! syntmp-x-986 3 syntmp-update-987))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-988 syntmp-update-989) (vector-set! syntmp-x-988 2 syntmp-update-989))) (syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-990 syntmp-update-991) (vector-set! syntmp-x-990 1 syntmp-update-991))) (syntmp-ribcage-labels-115 (lambda (syntmp-x-992) (vector-ref syntmp-x-992 3))) (syntmp-ribcage-marks-114 (lambda (syntmp-x-993) (vector-ref syntmp-x-993 2))) (syntmp-ribcage-symnames-113 (lambda (syntmp-x-994) (vector-ref syntmp-x-994 1))) (syntmp-ribcage?-112 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (= (vector-length syntmp-x-995) 4) (eq? (vector-ref syntmp-x-995 0) (quote ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-996 syntmp-marks-997 syntmp-labels-998) (vector (quote ribcage) syntmp-symnames-996 syntmp-marks-997 syntmp-labels-998))) (syntmp-gen-labels-110 (lambda (syntmp-ls-999) (if (null? syntmp-ls-999) (quote ()) (cons (syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-999)))))) (syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr) (syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons) (syntmp-id-sym-name&marks-105 (lambda (syntmp-x-1000 syntmp-w-1001) (if (syntmp-syntax-object?-88 syntmp-x-1000) (values (let ((syntmp-e-1002 (syntmp-syntax-object-expression-89 syntmp-x-1000))) (if (annotation? syntmp-e-1002) (annotation-expression syntmp-e-1002) syntmp-e-1002)) (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-1001) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-1000)))) (values (let ((syntmp-e-1003 syntmp-x-1000)) (if (annotation? syntmp-e-1003) (annotation-expression syntmp-e-1003) syntmp-e-1003)) (syntmp-wrap-marks-107 syntmp-w-1001))))) (syntmp-id?-104 (lambda (syntmp-x-1004) (cond ((symbol? syntmp-x-1004) #t) ((syntmp-syntax-object?-88 syntmp-x-1004) (symbol? (let ((syntmp-e-1005 (syntmp-syntax-object-expression-89 syntmp-x-1004))) (if (annotation? syntmp-e-1005) (annotation-expression syntmp-e-1005) syntmp-e-1005)))) ((annotation? syntmp-x-1004) (symbol? (annotation-expression syntmp-x-1004))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-1006) (and (syntmp-syntax-object?-88 syntmp-x-1006) (symbol? (let ((syntmp-e-1007 (syntmp-syntax-object-expression-89 syntmp-x-1006))) (if (annotation? syntmp-e-1007) (annotation-expression syntmp-e-1007) syntmp-e-1007)))))) (syntmp-global-extend-102 (lambda (syntmp-type-1008 syntmp-sym-1009 syntmp-val-1010) (syntmp-put-global-definition-hook-79 syntmp-sym-1009 (cons syntmp-type-1008 syntmp-val-1010) (module-name (current-module))))) (syntmp-lookup-101 (lambda (syntmp-x-1011 syntmp-r-1012 syntmp-mod-1013) (cond ((assq syntmp-x-1011 syntmp-r-1012) => cdr) ((symbol? syntmp-x-1011) (or (syntmp-get-global-definition-hook-80 syntmp-x-1011 syntmp-mod-1013) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100 (lambda (syntmp-r-1014) (if (null? syntmp-r-1014) (quote ()) (let ((syntmp-a-1015 (car syntmp-r-1014))) (if (eq? (cadr syntmp-a-1015) (quote macro)) (cons syntmp-a-1015 (syntmp-macros-only-env-100 (cdr syntmp-r-1014))) (syntmp-macros-only-env-100 (cdr syntmp-r-1014))))))) (syntmp-extend-var-env-99 (lambda (syntmp-labels-1016 syntmp-vars-1017 syntmp-r-1018) (if (null? syntmp-labels-1016) syntmp-r-1018 (syntmp-extend-var-env-99 (cdr syntmp-labels-1016) (cdr syntmp-vars-1017) (cons (cons (car syntmp-labels-1016) (cons (quote lexical) (car syntmp-vars-1017))) syntmp-r-1018))))) (syntmp-extend-env-98 (lambda (syntmp-labels-1019 syntmp-bindings-1020 syntmp-r-1021) (if (null? syntmp-labels-1019) syntmp-r-1021 (syntmp-extend-env-98 (cdr syntmp-labels-1019) (cdr syntmp-bindings-1020) (cons (cons (car syntmp-labels-1019) (car syntmp-bindings-1020)) syntmp-r-1021))))) (syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car) (syntmp-source-annotation-95 (lambda (syntmp-x-1022) (cond ((annotation? syntmp-x-1022) (annotation-source syntmp-x-1022)) ((syntmp-syntax-object?-88 syntmp-x-1022) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89 syntmp-x-1022))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda (syntmp-x-1023 syntmp-update-1024) (vector-set! syntmp-x-1023 3 syntmp-update-1024))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-1025 syntmp-update-1026) (vector-set! syntmp-x-1025 2 syntmp-update-1026))) (syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-1027 syntmp-update-1028) (vector-set! syntmp-x-1027 1 syntmp-update-1028))) (syntmp-syntax-object-module-91 (lambda (syntmp-x-1029) (vector-ref syntmp-x-1029 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-1030) (vector-ref syntmp-x-1030 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-1031) (vector-ref syntmp-x-1031 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-1032) (and (vector? syntmp-x-1032) (= (vector-length syntmp-x-1032) 4) (eq? (vector-ref syntmp-x-1032 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-1033 syntmp-wrap-1034 syntmp-module-1035) (vector (quote syntax-object) syntmp-expression-1033 syntmp-wrap-1034 syntmp-module-1035))) (syntmp-build-letrec-86 (lambda (syntmp-src-1036 syntmp-vars-1037 syntmp-val-exps-1038 syntmp-body-exp-1039) (if (null? syntmp-vars-1037) (syntmp-build-annotated-81 syntmp-src-1036 syntmp-body-exp-1039) (syntmp-build-annotated-81 syntmp-src-1036 (list (quote letrec) (map list syntmp-vars-1037 syntmp-val-exps-1038) syntmp-body-exp-1039))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1040 syntmp-vars-1041 syntmp-val-exps-1042 syntmp-body-exp-1043) (if (null? syntmp-vars-1041) (syntmp-build-annotated-81 syntmp-src-1040 syntmp-body-exp-1043) (syntmp-build-annotated-81 syntmp-src-1040 (list (quote let) (car syntmp-vars-1041) (map list (cdr syntmp-vars-1041) syntmp-val-exps-1042) syntmp-body-exp-1043))))) (syntmp-build-let-84 (lambda (syntmp-src-1044 syntmp-vars-1045 syntmp-val-exps-1046 syntmp-body-exp-1047) (if (null? syntmp-vars-1045) (syntmp-build-annotated-81 syntmp-src-1044 syntmp-body-exp-1047) (syntmp-build-annotated-81 syntmp-src-1044 (list (quote let) (map list syntmp-vars-1045 syntmp-val-exps-1046) syntmp-body-exp-1047))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1048 syntmp-exps-1049) (if (null? (cdr syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (car syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (cons (quote begin) syntmp-exps-1049))))) (syntmp-build-data-82 (lambda (syntmp-src-1050 syntmp-exp-1051) (if (and (self-evaluating? syntmp-exp-1051) (not (vector? syntmp-exp-1051))) (syntmp-build-annotated-81 syntmp-src-1050 syntmp-exp-1051) (syntmp-build-annotated-81 syntmp-src-1050 (list (quote quote) syntmp-exp-1051))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1052 syntmp-exp-1053) (if (and syntmp-src-1052 (not (annotation? syntmp-exp-1053))) (make-annotation syntmp-exp-1053 syntmp-src-1052 #t) syntmp-exp-1053))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1054 syntmp-module-1055) (let ((syntmp-module-1056 (if syntmp-module-1055 (resolve-module syntmp-module-1055) (warn "wha" syntmp-symbol-1054 (current-module))))) (let ((syntmp-v-1057 (module-variable syntmp-module-1056 syntmp-symbol-1054))) (and syntmp-v-1057 (or (object-property syntmp-v-1057 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1057) (macro? (variable-ref syntmp-v-1057)) (macro-transformer (variable-ref syntmp-v-1057)) guile-macro))))))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1058 syntmp-binding-1059 syntmp-module-1060) (let ((syntmp-module-1061 (if syntmp-module-1060 (resolve-module syntmp-module-1060) (warn "wha" syntmp-symbol-1058 (current-module))))) (let ((syntmp-v-1062 (or (module-variable syntmp-module-1061 syntmp-symbol-1058) (let ((syntmp-v-1063 (make-variable sc-macro))) (begin (module-add! syntmp-module-1061 syntmp-symbol-1058 syntmp-v-1063) syntmp-v-1063))))) (begin (if (not (and (symbol-property syntmp-symbol-1058 (quote primitive-syntax)) (eq? syntmp-module-1061 the-syncase-module))) (variable-set! syntmp-v-1062 sc-macro)) (set-object-property! syntmp-v-1062 (quote *sc-expander*) syntmp-binding-1059)))))) (syntmp-error-hook-78 (lambda (syntmp-who-1064 syntmp-why-1065 syntmp-what-1066) (error syntmp-who-1064 "~a ~s" syntmp-why-1065 syntmp-what-1066))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1067 syntmp-mod-1068) (eval (list syntmp-noexpand-71 syntmp-x-1067) (if syntmp-mod-1068 (resolve-module syntmp-mod-1068) (interaction-environment))))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1069 syntmp-mod-1070) (eval (list syntmp-noexpand-71 syntmp-x-1069) (if syntmp-mod-1070 (resolve-module syntmp-mod-1070) (interaction-environment))))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1071 syntmp-r-1072 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) ((lambda (syntmp-tmp-1076) ((lambda (syntmp-tmp-1077) (if (if syntmp-tmp-1077 (apply (lambda (syntmp-_-1078 syntmp-var-1079 syntmp-val-1080 syntmp-e1-1081 syntmp-e2-1082) (syntmp-valid-bound-ids?-129 syntmp-var-1079)) syntmp-tmp-1077) #f) (apply (lambda (syntmp-_-1084 syntmp-var-1085 syntmp-val-1086 syntmp-e1-1087 syntmp-e2-1088) (let ((syntmp-names-1089 (map (lambda (syntmp-x-1090) (syntmp-id-var-name-126 syntmp-x-1090 syntmp-w-1073)) syntmp-var-1085))) (begin (for-each (lambda (syntmp-id-1092 syntmp-n-1093) (let ((syntmp-t-1094 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1093 syntmp-r-1072 syntmp-mod-1075)))) (if (memv syntmp-t-1094 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1092 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) "identifier out of context")))) syntmp-var-1085 syntmp-names-1089) (syntmp-chi-body-144 (cons syntmp-e1-1087 syntmp-e2-1088) (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) (syntmp-extend-env-98 syntmp-names-1089 (let ((syntmp-trans-r-1097 (syntmp-macros-only-env-100 syntmp-r-1072))) (map (lambda (syntmp-x-1098) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-1098 syntmp-trans-r-1097 syntmp-w-1073 syntmp-mod-1075) syntmp-mod-1075))) syntmp-val-1086)) syntmp-r-1072) syntmp-w-1073 syntmp-mod-1075)))) syntmp-tmp-1077) ((lambda (syntmp-_-1100) (syntax-error (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075))) syntmp-tmp-1076))) (syntax-dispatch syntmp-tmp-1076 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1071))) (syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1101 syntmp-r-1102 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105) ((lambda (syntmp-tmp-1106) ((lambda (syntmp-tmp-1107) (if syntmp-tmp-1107 (apply (lambda (syntmp-_-1108 syntmp-e-1109) (syntmp-build-data-82 syntmp-s-1104 (syntmp-strip-151 syntmp-e-1109 syntmp-w-1103))) syntmp-tmp-1107) ((lambda (syntmp-_-1110) (syntax-error (syntmp-source-wrap-133 syntmp-e-1101 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105))) syntmp-tmp-1106))) (syntax-dispatch syntmp-tmp-1106 (quote (any any))))) syntmp-e-1101))) (syntmp-global-extend-102 (quote core) (quote syntax) (letrec ((syntmp-regen-1118 (lambda (syntmp-x-1119) (let ((syntmp-t-1120 (car syntmp-x-1119))) (if (memv syntmp-t-1120 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1119) (syntmp-regen-1118 (caddr syntmp-x-1119)))) (if (memv syntmp-t-1120 (quote (map))) (let ((syntmp-ls-1121 (map syntmp-regen-1118 (cdr syntmp-x-1119)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1121) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1121))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1119)) (map syntmp-regen-1118 (cdr syntmp-x-1119)))))))))))) (syntmp-gen-vector-1117 (lambda (syntmp-x-1122) (cond ((eq? (car syntmp-x-1122) (quote list)) (cons (quote vector) (cdr syntmp-x-1122))) ((eq? (car syntmp-x-1122) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1122)))) (else (list (quote list->vector) syntmp-x-1122))))) (syntmp-gen-append-1116 (lambda (syntmp-x-1123 syntmp-y-1124) (if (equal? syntmp-y-1124 (quote (quote ()))) syntmp-x-1123 (list (quote append) syntmp-x-1123 syntmp-y-1124)))) (syntmp-gen-cons-1115 (lambda (syntmp-x-1125 syntmp-y-1126) (let ((syntmp-t-1127 (car syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (quote))) (if (eq? (car syntmp-x-1125) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1125) (cadr syntmp-y-1126))) (if (eq? (cadr syntmp-y-1126) (quote ())) (list (quote list) syntmp-x-1125) (list (quote cons) syntmp-x-1125 syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (list))) (cons (quote list) (cons syntmp-x-1125 (cdr syntmp-y-1126))) (list (quote cons) syntmp-x-1125 syntmp-y-1126)))))) (syntmp-gen-map-1114 (lambda (syntmp-e-1128 syntmp-map-env-1129) (let ((syntmp-formals-1130 (map cdr syntmp-map-env-1129)) (syntmp-actuals-1131 (map (lambda (syntmp-x-1132) (list (quote ref) (car syntmp-x-1132))) syntmp-map-env-1129))) (cond ((eq? (car syntmp-e-1128) (quote ref)) (car syntmp-actuals-1131)) ((andmap (lambda (syntmp-x-1133) (and (eq? (car syntmp-x-1133) (quote ref)) (memq (cadr syntmp-x-1133) syntmp-formals-1130))) (cdr syntmp-e-1128)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1128)) (map (let ((syntmp-r-1134 (map cons syntmp-formals-1130 syntmp-actuals-1131))) (lambda (syntmp-x-1135) (cdr (assq (cadr syntmp-x-1135) syntmp-r-1134)))) (cdr syntmp-e-1128))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1130 syntmp-e-1128) syntmp-actuals-1131))))))) (syntmp-gen-mappend-1113 (lambda (syntmp-e-1136 syntmp-map-env-1137) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1114 syntmp-e-1136 syntmp-map-env-1137)))) (syntmp-gen-ref-1112 (lambda (syntmp-src-1138 syntmp-var-1139 syntmp-level-1140 syntmp-maps-1141) (if (syntmp-fx=-74 syntmp-level-1140 0) (values syntmp-var-1139 syntmp-maps-1141) (if (null? syntmp-maps-1141) (syntax-error syntmp-src-1138 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1112 syntmp-src-1138 syntmp-var-1139 (syntmp-fx--73 syntmp-level-1140 1) (cdr syntmp-maps-1141))) (lambda (syntmp-outer-var-1142 syntmp-outer-maps-1143) (let ((syntmp-b-1144 (assq syntmp-outer-var-1142 (car syntmp-maps-1141)))) (if syntmp-b-1144 (values (cdr syntmp-b-1144) syntmp-maps-1141) (let ((syntmp-inner-var-1145 (syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1145 (cons (cons (cons syntmp-outer-var-1142 syntmp-inner-var-1145) (car syntmp-maps-1141)) syntmp-outer-maps-1143))))))))))) (syntmp-gen-syntax-1111 (lambda (syntmp-src-1146 syntmp-e-1147 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151) (if (syntmp-id?-104 syntmp-e-1147) (let ((syntmp-label-1152 (syntmp-id-var-name-126 syntmp-e-1147 (quote (()))))) (let ((syntmp-b-1153 (syntmp-lookup-101 syntmp-label-1152 syntmp-r-1148 syntmp-mod-1151))) (if (eq? (syntmp-binding-type-96 syntmp-b-1153) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1154 (syntmp-binding-value-97 syntmp-b-1153))) (syntmp-gen-ref-1112 syntmp-src-1146 (car syntmp-var.lev-1154) (cdr syntmp-var.lev-1154) syntmp-maps-1149))) (lambda (syntmp-var-1155 syntmp-maps-1156) (values (list (quote ref) syntmp-var-1155) syntmp-maps-1156))) (if (syntmp-ellipsis?-1150 syntmp-e-1147) (syntax-error syntmp-src-1146 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1147) syntmp-maps-1149))))) ((lambda (syntmp-tmp-1157) ((lambda (syntmp-tmp-1158) (if (if syntmp-tmp-1158 (apply (lambda (syntmp-dots-1159 syntmp-e-1160) (syntmp-ellipsis?-1150 syntmp-dots-1159)) syntmp-tmp-1158) #f) (apply (lambda (syntmp-dots-1161 syntmp-e-1162) (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-e-1162 syntmp-r-1148 syntmp-maps-1149 (lambda (syntmp-x-1163) #f) syntmp-mod-1151)) syntmp-tmp-1158) ((lambda (syntmp-tmp-1164) (if (if syntmp-tmp-1164 (apply (lambda (syntmp-x-1165 syntmp-dots-1166 syntmp-y-1167) (syntmp-ellipsis?-1150 syntmp-dots-1166)) syntmp-tmp-1164) #f) (apply (lambda (syntmp-x-1168 syntmp-dots-1169 syntmp-y-1170) (let syntmp-f-1171 ((syntmp-y-1172 syntmp-y-1170) (syntmp-k-1173 (lambda (syntmp-maps-1174) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-x-1168 syntmp-r-1148 (cons (quote ()) syntmp-maps-1174) syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1175 syntmp-maps-1176) (if (null? (car syntmp-maps-1176)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-map-1114 syntmp-x-1175 (car syntmp-maps-1176)) (cdr syntmp-maps-1176)))))))) ((lambda (syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if (if syntmp-tmp-1178 (apply (lambda (syntmp-dots-1179 syntmp-y-1180) (syntmp-ellipsis?-1150 syntmp-dots-1179)) syntmp-tmp-1178) #f) (apply (lambda (syntmp-dots-1181 syntmp-y-1182) (syntmp-f-1171 syntmp-y-1182 (lambda (syntmp-maps-1183) (call-with-values (lambda () (syntmp-k-1173 (cons (quote ()) syntmp-maps-1183))) (lambda (syntmp-x-1184 syntmp-maps-1185) (if (null? (car syntmp-maps-1185)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1113 syntmp-x-1184 (car syntmp-maps-1185)) (cdr syntmp-maps-1185)))))))) syntmp-tmp-1178) ((lambda (syntmp-_-1186) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-y-1172 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1187 syntmp-maps-1188) (call-with-values (lambda () (syntmp-k-1173 syntmp-maps-1188)) (lambda (syntmp-x-1189 syntmp-maps-1190) (values (syntmp-gen-append-1116 syntmp-x-1189 syntmp-y-1187) syntmp-maps-1190)))))) syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177 (quote (any . any))))) syntmp-y-1172))) syntmp-tmp-1164) ((lambda (syntmp-tmp-1191) (if syntmp-tmp-1191 (apply (lambda (syntmp-x-1192 syntmp-y-1193) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-x-1192 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1194 syntmp-maps-1195) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-y-1193 syntmp-r-1148 syntmp-maps-1195 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1196 syntmp-maps-1197) (values (syntmp-gen-cons-1115 syntmp-x-1194 syntmp-y-1196) syntmp-maps-1197)))))) syntmp-tmp-1191) ((lambda (syntmp-tmp-1198) (if syntmp-tmp-1198 (apply (lambda (syntmp-e1-1199 syntmp-e2-1200) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 (cons syntmp-e1-1199 syntmp-e2-1200) syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-e-1202 syntmp-maps-1203) (values (syntmp-gen-vector-1117 syntmp-e-1202) syntmp-maps-1203)))) syntmp-tmp-1198) ((lambda (syntmp-_-1204) (values (list (quote quote) syntmp-e-1147) syntmp-maps-1149)) syntmp-tmp-1157))) (syntax-dispatch syntmp-tmp-1157 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1157 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1157 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1157 (quote (any any))))) syntmp-e-1147))))) (lambda (syntmp-e-1205 syntmp-r-1206 syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209) (let ((syntmp-e-1210 (syntmp-source-wrap-133 syntmp-e-1205 syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209))) ((lambda (syntmp-tmp-1211) ((lambda (syntmp-tmp-1212) (if syntmp-tmp-1212 (apply (lambda (syntmp-_-1213 syntmp-x-1214) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-e-1210 syntmp-x-1214 syntmp-r-1206 (quote ()) syntmp-ellipsis?-149 syntmp-mod-1209)) (lambda (syntmp-e-1215 syntmp-maps-1216) (syntmp-regen-1118 syntmp-e-1215)))) syntmp-tmp-1212) ((lambda (syntmp-_-1217) (syntax-error syntmp-e-1210)) syntmp-tmp-1211))) (syntax-dispatch syntmp-tmp-1211 (quote (any any))))) syntmp-e-1210))))) (syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1218 syntmp-r-1219 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) ((lambda (syntmp-tmp-1223) ((lambda (syntmp-tmp-1224) (if syntmp-tmp-1224 (apply (lambda (syntmp-_-1225 syntmp-c-1226) (syntmp-chi-lambda-clause-145 (syntmp-source-wrap-133 syntmp-e-1218 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) syntmp-c-1226 syntmp-r-1219 syntmp-w-1220 syntmp-mod-1222 (lambda (syntmp-vars-1227 syntmp-body-1228) (syntmp-build-annotated-81 syntmp-s-1221 (list (quote lambda) syntmp-vars-1227 syntmp-body-1228))))) syntmp-tmp-1224) (syntax-error syntmp-tmp-1223))) (syntax-dispatch syntmp-tmp-1223 (quote (any . any))))) syntmp-e-1218))) (syntmp-global-extend-102 (quote core) (quote let) (letrec ((syntmp-chi-let-1229 (lambda (syntmp-e-1230 syntmp-r-1231 syntmp-w-1232 syntmp-s-1233 syntmp-mod-1234 syntmp-constructor-1235 syntmp-ids-1236 syntmp-vals-1237 syntmp-exps-1238) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1236)) (syntax-error syntmp-e-1230 "duplicate bound variable in") (let ((syntmp-labels-1239 (syntmp-gen-labels-110 syntmp-ids-1236)) (syntmp-new-vars-1240 (map syntmp-gen-var-152 syntmp-ids-1236))) (let ((syntmp-nw-1241 (syntmp-make-binding-wrap-121 syntmp-ids-1236 syntmp-labels-1239 syntmp-w-1232)) (syntmp-nr-1242 (syntmp-extend-var-env-99 syntmp-labels-1239 syntmp-new-vars-1240 syntmp-r-1231))) (syntmp-constructor-1235 syntmp-s-1233 syntmp-new-vars-1240 (map (lambda (syntmp-x-1243) (syntmp-chi-140 syntmp-x-1243 syntmp-r-1231 syntmp-w-1232 syntmp-mod-1234)) syntmp-vals-1237) (syntmp-chi-body-144 syntmp-exps-1238 (syntmp-source-wrap-133 syntmp-e-1230 syntmp-nw-1241 syntmp-s-1233 syntmp-mod-1234) syntmp-nr-1242 syntmp-nw-1241 syntmp-mod-1234)))))))) (lambda (syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248) ((lambda (syntmp-tmp-1249) ((lambda (syntmp-tmp-1250) (if syntmp-tmp-1250 (apply (lambda (syntmp-_-1251 syntmp-id-1252 syntmp-val-1253 syntmp-e1-1254 syntmp-e2-1255) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-let-84 syntmp-id-1252 syntmp-val-1253 (cons syntmp-e1-1254 syntmp-e2-1255))) syntmp-tmp-1250) ((lambda (syntmp-tmp-1259) (if (if syntmp-tmp-1259 (apply (lambda (syntmp-_-1260 syntmp-f-1261 syntmp-id-1262 syntmp-val-1263 syntmp-e1-1264 syntmp-e2-1265) (syntmp-id?-104 syntmp-f-1261)) syntmp-tmp-1259) #f) (apply (lambda (syntmp-_-1266 syntmp-f-1267 syntmp-id-1268 syntmp-val-1269 syntmp-e1-1270 syntmp-e2-1271) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-named-let-85 (cons syntmp-f-1267 syntmp-id-1268) syntmp-val-1269 (cons syntmp-e1-1270 syntmp-e2-1271))) syntmp-tmp-1259) ((lambda (syntmp-_-1275) (syntax-error (syntmp-source-wrap-133 syntmp-e-1244 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248))) syntmp-tmp-1249))) (syntax-dispatch syntmp-tmp-1249 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1249 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1244)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda (syntmp-e-1276 syntmp-r-1277 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-_-1283 syntmp-id-1284 syntmp-val-1285 syntmp-e1-1286 syntmp-e2-1287) (let ((syntmp-ids-1288 syntmp-id-1284)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1288)) (syntax-error syntmp-e-1276 "duplicate bound variable in") (let ((syntmp-labels-1290 (syntmp-gen-labels-110 syntmp-ids-1288)) (syntmp-new-vars-1291 (map syntmp-gen-var-152 syntmp-ids-1288))) (let ((syntmp-w-1292 (syntmp-make-binding-wrap-121 syntmp-ids-1288 syntmp-labels-1290 syntmp-w-1278)) (syntmp-r-1293 (syntmp-extend-var-env-99 syntmp-labels-1290 syntmp-new-vars-1291 syntmp-r-1277))) (syntmp-build-letrec-86 syntmp-s-1279 syntmp-new-vars-1291 (map (lambda (syntmp-x-1294) (syntmp-chi-140 syntmp-x-1294 syntmp-r-1293 syntmp-w-1292 syntmp-mod-1280)) syntmp-val-1285) (syntmp-chi-body-144 (cons syntmp-e1-1286 syntmp-e2-1287) (syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1292 syntmp-s-1279 syntmp-mod-1280) syntmp-r-1293 syntmp-w-1292 syntmp-mod-1280))))))) syntmp-tmp-1282) ((lambda (syntmp-_-1297) (syntax-error (syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280))) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1276))) (syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1298 syntmp-r-1299 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302) ((lambda (syntmp-tmp-1303) ((lambda (syntmp-tmp-1304) (if (if syntmp-tmp-1304 (apply (lambda (syntmp-_-1305 syntmp-id-1306 syntmp-val-1307) (syntmp-id?-104 syntmp-id-1306)) syntmp-tmp-1304) #f) (apply (lambda (syntmp-_-1308 syntmp-id-1309 syntmp-val-1310) (let ((syntmp-val-1311 (syntmp-chi-140 syntmp-val-1310 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (syntmp-n-1312 (syntmp-id-var-name-126 syntmp-id-1309 syntmp-w-1300))) (let ((syntmp-b-1313 (syntmp-lookup-101 syntmp-n-1312 syntmp-r-1299 syntmp-mod-1302))) (let ((syntmp-t-1314 (syntmp-binding-type-96 syntmp-b-1313))) (if (memv syntmp-t-1314 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (syntmp-binding-value-97 syntmp-b-1313) syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (make-module-ref syntmp-mod-1302 syntmp-n-1312 #f) syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-id-1309 syntmp-w-1300 syntmp-mod-1302) "identifier out of context") (syntax-error (syntmp-source-wrap-133 syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))))))))) syntmp-tmp-1304) ((lambda (syntmp-tmp-1315) (if syntmp-tmp-1315 (apply (lambda (syntmp-_-1316 syntmp-head-1317 syntmp-tail-1318 syntmp-val-1319) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-head-1317 syntmp-r-1299 (quote (())) #f #f syntmp-mod-1302)) (lambda (syntmp-type-1320 syntmp-value-1321 syntmp-ee-1322 syntmp-ww-1323 syntmp-ss-1324 syntmp-modmod-1325) (let ((syntmp-t-1326 syntmp-type-1320)) (if (memv syntmp-t-1326 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1321 (cons syntmp-head-1317 syntmp-tail-1318))) (lambda (syntmp-id-1328 syntmp-mod-1329) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (make-module-ref syntmp-mod-1329 syntmp-id-1328 #f) syntmp-val-1319)))) (syntmp-build-annotated-81 syntmp-s-1301 (cons (syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1317) syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302) (map (lambda (syntmp-e-1330) (syntmp-chi-140 syntmp-e-1330 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (append syntmp-tail-1318 (list syntmp-val-1319)))))))))) syntmp-tmp-1315) ((lambda (syntmp-_-1332) (syntax-error (syntmp-source-wrap-133 syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))) syntmp-tmp-1303))) (syntax-dispatch syntmp-tmp-1303 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1303 (quote (any any any))))) syntmp-e-1298))) (syntmp-global-extend-102 (quote module-ref) (quote @) (lambda (syntmp-e-1333) ((lambda (syntmp-tmp-1334) ((lambda (syntmp-tmp-1335) (if (if syntmp-tmp-1335 (apply (lambda (syntmp-_-1336 syntmp-mod-1337 syntmp-id-1338) (and (andmap syntmp-id?-104 syntmp-mod-1337) (syntmp-id?-104 syntmp-id-1338))) syntmp-tmp-1335) #f) (apply (lambda (syntmp-_-1340 syntmp-mod-1341 syntmp-id-1342) (values (syntax-object->datum syntmp-id-1342) (syntax-object->datum (append syntmp-mod-1341 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1335) (syntax-error syntmp-tmp-1334))) (syntax-dispatch syntmp-tmp-1334 (quote (any each-any any))))) syntmp-e-1333))) (syntmp-global-extend-102 (quote module-ref) (quote @@) (lambda (syntmp-e-1344) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if (if syntmp-tmp-1346 (apply (lambda (syntmp-_-1347 syntmp-mod-1348 syntmp-id-1349) (and (andmap syntmp-id?-104 syntmp-mod-1348) (syntmp-id?-104 syntmp-id-1349))) syntmp-tmp-1346) #f) (apply (lambda (syntmp-_-1351 syntmp-mod-1352 syntmp-id-1353) (values (syntax-object->datum syntmp-id-1353) (syntax-object->datum syntmp-mod-1352))) syntmp-tmp-1346) (syntax-error syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any each-any any))))) syntmp-e-1344))) (syntmp-global-extend-102 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ())) (syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1358 (lambda (syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-mod-1363) (if (null? syntmp-clauses-1361) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1359)) ((lambda (syntmp-tmp-1364) ((lambda (syntmp-tmp-1365) (if syntmp-tmp-1365 (apply (lambda (syntmp-pat-1366 syntmp-exp-1367) (if (and (syntmp-id?-104 syntmp-pat-1366) (andmap (lambda (syntmp-x-1368) (not (syntmp-free-id=?-127 syntmp-pat-1366 syntmp-x-1368))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1360))) (let ((syntmp-labels-1369 (list (syntmp-gen-label-109))) (syntmp-var-1370 (syntmp-gen-var-152 syntmp-pat-1366))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1370) (syntmp-chi-140 syntmp-exp-1367 (syntmp-extend-env-98 syntmp-labels-1369 (list (cons (quote syntax) (cons syntmp-var-1370 0))) syntmp-r-1362) (syntmp-make-binding-wrap-121 (list syntmp-pat-1366) syntmp-labels-1369 (quote (()))) syntmp-mod-1363))) syntmp-x-1359))) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1366 #t syntmp-exp-1367 syntmp-mod-1363))) syntmp-tmp-1365) ((lambda (syntmp-tmp-1371) (if syntmp-tmp-1371 (apply (lambda (syntmp-pat-1372 syntmp-fender-1373 syntmp-exp-1374) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1372 syntmp-fender-1373 syntmp-exp-1374 syntmp-mod-1363)) syntmp-tmp-1371) ((lambda (syntmp-_-1375) (syntax-error (car syntmp-clauses-1361) "invalid syntax-case clause")) syntmp-tmp-1364))) (syntax-dispatch syntmp-tmp-1364 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1364 (quote (any any))))) (car syntmp-clauses-1361))))) (syntmp-gen-clause-1357 (lambda (syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-pat-1380 syntmp-fender-1381 syntmp-exp-1382 syntmp-mod-1383) (call-with-values (lambda () (syntmp-convert-pattern-1355 syntmp-pat-1380 syntmp-keys-1377)) (lambda (syntmp-p-1384 syntmp-pvars-1385) (cond ((not (syntmp-distinct-bound-ids?-130 (map car syntmp-pvars-1385))) (syntax-error syntmp-pat-1380 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1386) (not (syntmp-ellipsis?-149 (car syntmp-x-1386)))) syntmp-pvars-1385)) (syntax-error syntmp-pat-1380 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1387 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1387) (let ((syntmp-y-1388 (syntmp-build-annotated-81 #f syntmp-y-1387))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1389) ((lambda (syntmp-tmp-1390) (if syntmp-tmp-1390 (apply (lambda () syntmp-y-1388) syntmp-tmp-1390) ((lambda (syntmp-_-1391) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1388 (syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-fender-1381 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1389))) (syntax-dispatch syntmp-tmp-1389 (quote #(atom #t))))) syntmp-fender-1381) (syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-exp-1382 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-gen-syntax-case-1358 syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-mod-1383)))))) (if (eq? syntmp-p-1384 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1376)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1376 (syntmp-build-data-82 #f syntmp-p-1384))))))))))))) (syntmp-build-dispatch-call-1356 (lambda (syntmp-pvars-1392 syntmp-exp-1393 syntmp-y-1394 syntmp-r-1395 syntmp-mod-1396) (let ((syntmp-ids-1397 (map car syntmp-pvars-1392)) (syntmp-levels-1398 (map cdr syntmp-pvars-1392))) (let ((syntmp-labels-1399 (syntmp-gen-labels-110 syntmp-ids-1397)) (syntmp-new-vars-1400 (map syntmp-gen-var-152 syntmp-ids-1397))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1400 (syntmp-chi-140 syntmp-exp-1393 (syntmp-extend-env-98 syntmp-labels-1399 (map (lambda (syntmp-var-1401 syntmp-level-1402) (cons (quote syntax) (cons syntmp-var-1401 syntmp-level-1402))) syntmp-new-vars-1400 (map cdr syntmp-pvars-1392)) syntmp-r-1395) (syntmp-make-binding-wrap-121 syntmp-ids-1397 syntmp-labels-1399 (quote (()))) syntmp-mod-1396))) syntmp-y-1394)))))) (syntmp-convert-pattern-1355 (lambda (syntmp-pattern-1403 syntmp-keys-1404) (let syntmp-cvt-1405 ((syntmp-p-1406 syntmp-pattern-1403) (syntmp-n-1407 0) (syntmp-ids-1408 (quote ()))) (if (syntmp-id?-104 syntmp-p-1406) (if (syntmp-bound-id-member?-131 syntmp-p-1406 syntmp-keys-1404) (values (vector (quote free-id) syntmp-p-1406) syntmp-ids-1408) (values (quote any) (cons (cons syntmp-p-1406 syntmp-n-1407) syntmp-ids-1408))) ((lambda (syntmp-tmp-1409) ((lambda (syntmp-tmp-1410) (if (if syntmp-tmp-1410 (apply (lambda (syntmp-x-1411 syntmp-dots-1412) (syntmp-ellipsis?-149 syntmp-dots-1412)) syntmp-tmp-1410) #f) (apply (lambda (syntmp-x-1413 syntmp-dots-1414) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1413 (syntmp-fx+-72 syntmp-n-1407 1) syntmp-ids-1408)) (lambda (syntmp-p-1415 syntmp-ids-1416) (values (if (eq? syntmp-p-1415 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1415)) syntmp-ids-1416)))) syntmp-tmp-1410) ((lambda (syntmp-tmp-1417) (if syntmp-tmp-1417 (apply (lambda (syntmp-x-1418 syntmp-y-1419) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-y-1419 syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-y-1420 syntmp-ids-1421) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1418 syntmp-n-1407 syntmp-ids-1421)) (lambda (syntmp-x-1422 syntmp-ids-1423) (values (cons syntmp-x-1422 syntmp-y-1420) syntmp-ids-1423)))))) syntmp-tmp-1417) ((lambda (syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda () (values (quote ()) syntmp-ids-1408)) syntmp-tmp-1424) ((lambda (syntmp-tmp-1425) (if syntmp-tmp-1425 (apply (lambda (syntmp-x-1426) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1426 syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-p-1428 syntmp-ids-1429) (values (vector (quote vector) syntmp-p-1428) syntmp-ids-1429)))) syntmp-tmp-1425) ((lambda (syntmp-x-1430) (values (vector (quote atom) (syntmp-strip-151 syntmp-p-1406 (quote (())))) syntmp-ids-1408)) syntmp-tmp-1409))) (syntax-dispatch syntmp-tmp-1409 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1409 (quote ()))))) (syntax-dispatch syntmp-tmp-1409 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1409 (quote (any any))))) syntmp-p-1406)))))) (lambda (syntmp-e-1431 syntmp-r-1432 syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435) (let ((syntmp-e-1436 (syntmp-source-wrap-133 syntmp-e-1431 syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435))) ((lambda (syntmp-tmp-1437) ((lambda (syntmp-tmp-1438) (if syntmp-tmp-1438 (apply (lambda (syntmp-_-1439 syntmp-val-1440 syntmp-key-1441 syntmp-m-1442) (if (andmap (lambda (syntmp-x-1443) (and (syntmp-id?-104 syntmp-x-1443) (not (syntmp-ellipsis?-149 syntmp-x-1443)))) syntmp-key-1441) (let ((syntmp-x-1445 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1434 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1445) (syntmp-gen-syntax-case-1358 (syntmp-build-annotated-81 #f syntmp-x-1445) syntmp-key-1441 syntmp-m-1442 syntmp-r-1432 syntmp-mod-1435))) (syntmp-chi-140 syntmp-val-1440 syntmp-r-1432 (quote (())) syntmp-mod-1435)))) (syntax-error syntmp-e-1436 "invalid literals list in"))) syntmp-tmp-1438) (syntax-error syntmp-tmp-1437))) (syntax-dispatch syntmp-tmp-1437 (quote (any any each-any . each-any))))) syntmp-e-1436))))) (set! sc-expand (let ((syntmp-m-1448 (quote e)) (syntmp-esew-1449 (quote (eval)))) (lambda (syntmp-x-1450) (if (and (pair? syntmp-x-1450) (equal? (car syntmp-x-1450) syntmp-noexpand-71)) (cadr syntmp-x-1450) (syntmp-chi-top-139 syntmp-x-1450 (quote ()) (quote ((top))) syntmp-m-1448 syntmp-esew-1449 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1451 (quote e)) (syntmp-esew-1452 (quote (eval)))) (lambda (syntmp-x-1454 . syntmp-rest-1453) (if (and (pair? syntmp-x-1454) (equal? (car syntmp-x-1454) syntmp-noexpand-71)) (cadr syntmp-x-1454) (syntmp-chi-top-139 syntmp-x-1454 (quote ()) (quote ((top))) (if (null? syntmp-rest-1453) syntmp-m-1451 (car syntmp-rest-1453)) (if (or (null? syntmp-rest-1453) (null? (cdr syntmp-rest-1453))) syntmp-esew-1452 (cadr syntmp-rest-1453)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1455) (syntmp-nonsymbol-id?-103 syntmp-x-1455))) (set! datum->syntax-object (lambda (syntmp-id-1456 syntmp-datum-1457) (syntmp-make-syntax-object-87 syntmp-datum-1457 (syntmp-syntax-object-wrap-90 syntmp-id-1456) #f))) (set! syntax-object->datum (lambda (syntmp-x-1458) (syntmp-strip-151 syntmp-x-1458 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1459) (begin (let ((syntmp-x-1460 syntmp-ls-1459)) (if (not (list? syntmp-x-1460)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1460))) (map (lambda (syntmp-x-1461) (syntmp-wrap-132 (gensym) (quote ((top))) #f)) syntmp-ls-1459)))) (set! free-identifier=? (lambda (syntmp-x-1462 syntmp-y-1463) (begin (let ((syntmp-x-1464 syntmp-x-1462)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1464)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1464))) (let ((syntmp-x-1465 syntmp-y-1463)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1465)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1465))) (syntmp-free-id=?-127 syntmp-x-1462 syntmp-y-1463)))) (set! bound-identifier=? (lambda (syntmp-x-1466 syntmp-y-1467) (begin (let ((syntmp-x-1468 syntmp-x-1466)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1468)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1468))) (let ((syntmp-x-1469 syntmp-y-1467)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1469)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1469))) (syntmp-bound-id=?-128 syntmp-x-1466 syntmp-y-1467)))) (set! syntax-error (lambda (syntmp-object-1471 . syntmp-messages-1470) (begin (for-each (lambda (syntmp-x-1472) (let ((syntmp-x-1473 syntmp-x-1472)) (if (not (string? syntmp-x-1473)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1473)))) syntmp-messages-1470) (let ((syntmp-message-1474 (if (null? syntmp-messages-1470) "invalid syntax" (apply string-append syntmp-messages-1470)))) (syntmp-error-hook-78 #f syntmp-message-1474 (syntmp-strip-151 syntmp-object-1471 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1475 syntmp-v-1476) (begin (let ((syntmp-x-1477 syntmp-sym-1475)) (if (not (symbol? syntmp-x-1477)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1477))) (let ((syntmp-x-1478 syntmp-v-1476)) (if (not (procedure? syntmp-x-1478)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1478))) (syntmp-global-extend-102 (quote macro) syntmp-sym-1475 syntmp-v-1476)))) (letrec ((syntmp-match-1483 (lambda (syntmp-e-1484 syntmp-p-1485 syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488) (cond ((not syntmp-r-1487) #f) ((eq? syntmp-p-1485 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1484 syntmp-w-1486 syntmp-mod-1488) syntmp-r-1487)) ((syntmp-syntax-object?-88 syntmp-e-1484) (syntmp-match*-1482 (let ((syntmp-e-1489 (syntmp-syntax-object-expression-89 syntmp-e-1484))) (if (annotation? syntmp-e-1489) (annotation-expression syntmp-e-1489) syntmp-e-1489)) syntmp-p-1485 (syntmp-join-wraps-123 syntmp-w-1486 (syntmp-syntax-object-wrap-90 syntmp-e-1484)) syntmp-r-1487 (syntmp-syntax-object-module-91 syntmp-e-1484))) (else (syntmp-match*-1482 (let ((syntmp-e-1490 syntmp-e-1484)) (if (annotation? syntmp-e-1490) (annotation-expression syntmp-e-1490) syntmp-e-1490)) syntmp-p-1485 syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488))))) (syntmp-match*-1482 (lambda (syntmp-e-1491 syntmp-p-1492 syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) (cond ((null? syntmp-p-1492) (and (null? syntmp-e-1491) syntmp-r-1494)) ((pair? syntmp-p-1492) (and (pair? syntmp-e-1491) (syntmp-match-1483 (car syntmp-e-1491) (car syntmp-p-1492) syntmp-w-1493 (syntmp-match-1483 (cdr syntmp-e-1491) (cdr syntmp-p-1492) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) syntmp-mod-1495))) ((eq? syntmp-p-1492 (quote each-any)) (let ((syntmp-l-1496 (syntmp-match-each-any-1480 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495))) (and syntmp-l-1496 (cons syntmp-l-1496 syntmp-r-1494)))) (else (let ((syntmp-t-1497 (vector-ref syntmp-p-1492 0))) (if (memv syntmp-t-1497 (quote (each))) (if (null? syntmp-e-1491) (syntmp-match-empty-1481 (vector-ref syntmp-p-1492 1) syntmp-r-1494) (let ((syntmp-l-1498 (syntmp-match-each-1479 syntmp-e-1491 (vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-mod-1495))) (and syntmp-l-1498 (let syntmp-collect-1499 ((syntmp-l-1500 syntmp-l-1498)) (if (null? (car syntmp-l-1500)) syntmp-r-1494 (cons (map car syntmp-l-1500) (syntmp-collect-1499 (map cdr syntmp-l-1500)))))))) (if (memv syntmp-t-1497 (quote (free-id))) (and (syntmp-id?-104 syntmp-e-1491) (syntmp-free-id=?-127 (syntmp-wrap-132 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495) (vector-ref syntmp-p-1492 1)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (atom))) (and (equal? (vector-ref syntmp-p-1492 1) (syntmp-strip-151 syntmp-e-1491 syntmp-w-1493)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (vector))) (and (vector? syntmp-e-1491) (syntmp-match-1483 (vector->list syntmp-e-1491) (vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495))))))))))) (syntmp-match-empty-1481 (lambda (syntmp-p-1501 syntmp-r-1502) (cond ((null? syntmp-p-1501) syntmp-r-1502) ((eq? syntmp-p-1501 (quote any)) (cons (quote ()) syntmp-r-1502)) ((pair? syntmp-p-1501) (syntmp-match-empty-1481 (car syntmp-p-1501) (syntmp-match-empty-1481 (cdr syntmp-p-1501) syntmp-r-1502))) ((eq? syntmp-p-1501 (quote each-any)) (cons (quote ()) syntmp-r-1502)) (else (let ((syntmp-t-1503 (vector-ref syntmp-p-1501 0))) (if (memv syntmp-t-1503 (quote (each))) (syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502) (if (memv syntmp-t-1503 (quote (free-id atom))) syntmp-r-1502 (if (memv syntmp-t-1503 (quote (vector))) (syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502))))))))) (syntmp-match-each-any-1480 (lambda (syntmp-e-1504 syntmp-w-1505 syntmp-mod-1506) (cond ((annotation? syntmp-e-1504) (syntmp-match-each-any-1480 (annotation-expression syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506)) ((pair? syntmp-e-1504) (let ((syntmp-l-1507 (syntmp-match-each-any-1480 (cdr syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506))) (and syntmp-l-1507 (cons (syntmp-wrap-132 (car syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506) syntmp-l-1507)))) ((null? syntmp-e-1504) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1504) (syntmp-match-each-any-1480 (syntmp-syntax-object-expression-89 syntmp-e-1504) (syntmp-join-wraps-123 syntmp-w-1505 (syntmp-syntax-object-wrap-90 syntmp-e-1504)) syntmp-mod-1506)) (else #f)))) (syntmp-match-each-1479 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511) (cond ((annotation? syntmp-e-1508) (syntmp-match-each-1479 (annotation-expression syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511)) ((pair? syntmp-e-1508) (let ((syntmp-first-1512 (syntmp-match-1483 (car syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 (quote ()) syntmp-mod-1511))) (and syntmp-first-1512 (let ((syntmp-rest-1513 (syntmp-match-each-1479 (cdr syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511))) (and syntmp-rest-1513 (cons syntmp-first-1512 syntmp-rest-1513)))))) ((null? syntmp-e-1508) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1508) (syntmp-match-each-1479 (syntmp-syntax-object-expression-89 syntmp-e-1508) syntmp-p-1509 (syntmp-join-wraps-123 syntmp-w-1510 (syntmp-syntax-object-wrap-90 syntmp-e-1508)) (syntmp-syntax-object-module-91 syntmp-e-1508))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1514 syntmp-p-1515) (cond ((eq? syntmp-p-1515 (quote any)) (list syntmp-e-1514)) ((syntmp-syntax-object?-88 syntmp-e-1514) (syntmp-match*-1482 (let ((syntmp-e-1516 (syntmp-syntax-object-expression-89 syntmp-e-1514))) (if (annotation? syntmp-e-1516) (annotation-expression syntmp-e-1516) syntmp-e-1516)) syntmp-p-1515 (syntmp-syntax-object-wrap-90 syntmp-e-1514) (quote ()) (syntmp-syntax-object-module-91 syntmp-e-1514))) (else (syntmp-match*-1482 (let ((syntmp-e-1517 syntmp-e-1514)) (if (annotation? syntmp-e-1517) (annotation-expression syntmp-e-1517) syntmp-e-1517)) syntmp-p-1515 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-140))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1518) ((lambda (syntmp-tmp-1519) ((lambda (syntmp-tmp-1520) (if syntmp-tmp-1520 (apply (lambda (syntmp-_-1521 syntmp-e1-1522 syntmp-e2-1523) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1522 syntmp-e2-1523))) syntmp-tmp-1520) ((lambda (syntmp-tmp-1525) (if syntmp-tmp-1525 (apply (lambda (syntmp-_-1526 syntmp-out-1527 syntmp-in-1528 syntmp-e1-1529 syntmp-e2-1530) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1528 (quote ()) (list syntmp-out-1527 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1529 syntmp-e2-1530))))) syntmp-tmp-1525) ((lambda (syntmp-tmp-1532) (if syntmp-tmp-1532 (apply (lambda (syntmp-_-1533 syntmp-out-1534 syntmp-in-1535 syntmp-e1-1536 syntmp-e2-1537) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1535) (quote ()) (list syntmp-out-1534 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1536 syntmp-e2-1537))))) syntmp-tmp-1532) (syntax-error syntmp-tmp-1519))) (syntax-dispatch syntmp-tmp-1519 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any () any . each-any))))) syntmp-x-1518))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1559) ((lambda (syntmp-tmp-1560) ((lambda (syntmp-tmp-1561) (if syntmp-tmp-1561 (apply (lambda (syntmp-_-1562 syntmp-k-1563 syntmp-keyword-1564 syntmp-pattern-1565 syntmp-template-1566) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1563 (map (lambda (syntmp-tmp-1569 syntmp-tmp-1568) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1568) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1569))) syntmp-template-1566 syntmp-pattern-1565)))))) syntmp-tmp-1561) (syntax-error syntmp-tmp-1560))) (syntax-dispatch syntmp-tmp-1560 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1559))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1580) ((lambda (syntmp-tmp-1581) ((lambda (syntmp-tmp-1582) (if (if syntmp-tmp-1582 (apply (lambda (syntmp-let*-1583 syntmp-x-1584 syntmp-v-1585 syntmp-e1-1586 syntmp-e2-1587) (andmap identifier? syntmp-x-1584)) syntmp-tmp-1582) #f) (apply (lambda (syntmp-let*-1589 syntmp-x-1590 syntmp-v-1591 syntmp-e1-1592 syntmp-e2-1593) (let syntmp-f-1594 ((syntmp-bindings-1595 (map list syntmp-x-1590 syntmp-v-1591))) (if (null? syntmp-bindings-1595) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1592 syntmp-e2-1593))) ((lambda (syntmp-tmp-1599) ((lambda (syntmp-tmp-1600) (if syntmp-tmp-1600 (apply (lambda (syntmp-body-1601 syntmp-binding-1602) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1602) syntmp-body-1601)) syntmp-tmp-1600) (syntax-error syntmp-tmp-1599))) (syntax-dispatch syntmp-tmp-1599 (quote (any any))))) (list (syntmp-f-1594 (cdr syntmp-bindings-1595)) (car syntmp-bindings-1595)))))) syntmp-tmp-1582) (syntax-error syntmp-tmp-1581))) (syntax-dispatch syntmp-tmp-1581 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1580))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1622) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-_-1625 syntmp-var-1626 syntmp-init-1627 syntmp-step-1628 syntmp-e0-1629 syntmp-e1-1630 syntmp-c-1631) ((lambda (syntmp-tmp-1632) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-step-1634) ((lambda (syntmp-tmp-1635) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1636) ((lambda (syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-e1-1642 syntmp-e2-1643) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1642 syntmp-e2-1643)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1641) (syntax-error syntmp-tmp-1635))) (syntax-dispatch syntmp-tmp-1635 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1635 (quote ())))) syntmp-e1-1630)) syntmp-tmp-1633) (syntax-error syntmp-tmp-1632))) (syntax-dispatch syntmp-tmp-1632 (quote each-any)))) (map (lambda (syntmp-v-1650 syntmp-s-1651) ((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda () syntmp-v-1650) syntmp-tmp-1653) ((lambda (syntmp-tmp-1654) (if syntmp-tmp-1654 (apply (lambda (syntmp-e-1655) syntmp-e-1655) syntmp-tmp-1654) ((lambda (syntmp-_-1656) (syntax-error syntmp-orig-x-1622)) syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any)))))) (syntax-dispatch syntmp-tmp-1652 (quote ())))) syntmp-s-1651)) syntmp-var-1626 syntmp-step-1628))) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1622))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1684 (lambda (syntmp-x-1688 syntmp-y-1689) ((lambda (syntmp-tmp-1690) ((lambda (syntmp-tmp-1691) (if syntmp-tmp-1691 (apply (lambda (syntmp-x-1692 syntmp-y-1693) ((lambda (syntmp-tmp-1694) ((lambda (syntmp-tmp-1695) (if syntmp-tmp-1695 (apply (lambda (syntmp-dy-1696) ((lambda (syntmp-tmp-1697) ((lambda (syntmp-tmp-1698) (if syntmp-tmp-1698 (apply (lambda (syntmp-dx-1699) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1699 syntmp-dy-1696))) syntmp-tmp-1698) ((lambda (syntmp-_-1700) (if (null? syntmp-dy-1696) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693))) syntmp-tmp-1697))) (syntax-dispatch syntmp-tmp-1697 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1692)) syntmp-tmp-1695) ((lambda (syntmp-tmp-1701) (if syntmp-tmp-1701 (apply (lambda (syntmp-stuff-1702) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1692 syntmp-stuff-1702))) syntmp-tmp-1701) ((lambda (syntmp-else-1703) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693)) syntmp-tmp-1694))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1693)) syntmp-tmp-1691) (syntax-error syntmp-tmp-1690))) (syntax-dispatch syntmp-tmp-1690 (quote (any any))))) (list syntmp-x-1688 syntmp-y-1689)))) (syntmp-quasiappend-1685 (lambda (syntmp-x-1704 syntmp-y-1705) ((lambda (syntmp-tmp-1706) ((lambda (syntmp-tmp-1707) (if syntmp-tmp-1707 (apply (lambda (syntmp-x-1708 syntmp-y-1709) ((lambda (syntmp-tmp-1710) ((lambda (syntmp-tmp-1711) (if syntmp-tmp-1711 (apply (lambda () syntmp-x-1708) syntmp-tmp-1711) ((lambda (syntmp-_-1712) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1708 syntmp-y-1709)) syntmp-tmp-1710))) (syntax-dispatch syntmp-tmp-1710 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1709)) syntmp-tmp-1707) (syntax-error syntmp-tmp-1706))) (syntax-dispatch syntmp-tmp-1706 (quote (any any))))) (list syntmp-x-1704 syntmp-y-1705)))) (syntmp-quasivector-1686 (lambda (syntmp-x-1713) ((lambda (syntmp-tmp-1714) ((lambda (syntmp-x-1715) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-x-1718) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1718))) syntmp-tmp-1717) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-x-1721) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1721)) syntmp-tmp-1720) ((lambda (syntmp-_-1723) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1715)) syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1715)) syntmp-tmp-1714)) syntmp-x-1713))) (syntmp-quasi-1687 (lambda (syntmp-p-1724 syntmp-lev-1725) ((lambda (syntmp-tmp-1726) ((lambda (syntmp-tmp-1727) (if syntmp-tmp-1727 (apply (lambda (syntmp-p-1728) (if (= syntmp-lev-1725 0) syntmp-p-1728 (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1728) (- syntmp-lev-1725 1))))) syntmp-tmp-1727) ((lambda (syntmp-tmp-1729) (if syntmp-tmp-1729 (apply (lambda (syntmp-p-1730 syntmp-q-1731) (if (= syntmp-lev-1725 0) (syntmp-quasiappend-1685 syntmp-p-1730 (syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)) (syntmp-quasicons-1684 (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1730) (- syntmp-lev-1725 1))) (syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)))) syntmp-tmp-1729) ((lambda (syntmp-tmp-1732) (if syntmp-tmp-1732 (apply (lambda (syntmp-p-1733) (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1733) (+ syntmp-lev-1725 1)))) syntmp-tmp-1732) ((lambda (syntmp-tmp-1734) (if syntmp-tmp-1734 (apply (lambda (syntmp-p-1735 syntmp-q-1736) (syntmp-quasicons-1684 (syntmp-quasi-1687 syntmp-p-1735 syntmp-lev-1725) (syntmp-quasi-1687 syntmp-q-1736 syntmp-lev-1725))) syntmp-tmp-1734) ((lambda (syntmp-tmp-1737) (if syntmp-tmp-1737 (apply (lambda (syntmp-x-1738) (syntmp-quasivector-1686 (syntmp-quasi-1687 syntmp-x-1738 syntmp-lev-1725))) syntmp-tmp-1737) ((lambda (syntmp-p-1740) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1740)) syntmp-tmp-1726))) (syntax-dispatch syntmp-tmp-1726 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1726 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1724)))) (lambda (syntmp-x-1741) ((lambda (syntmp-tmp-1742) ((lambda (syntmp-tmp-1743) (if syntmp-tmp-1743 (apply (lambda (syntmp-_-1744 syntmp-e-1745) (syntmp-quasi-1687 syntmp-e-1745 0)) syntmp-tmp-1743) (syntax-error syntmp-tmp-1742))) (syntax-dispatch syntmp-tmp-1742 (quote (any any))))) syntmp-x-1741)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1805) (letrec ((syntmp-read-file-1806 (lambda (syntmp-fn-1807 syntmp-k-1808) (let ((syntmp-p-1809 (open-input-file syntmp-fn-1807))) (let syntmp-f-1810 ((syntmp-x-1811 (read syntmp-p-1809))) (if (eof-object? syntmp-x-1811) (begin (close-input-port syntmp-p-1809) (quote ())) (cons (datum->syntax-object syntmp-k-1808 syntmp-x-1811) (syntmp-f-1810 (read syntmp-p-1809))))))))) ((lambda (syntmp-tmp-1812) ((lambda (syntmp-tmp-1813) (if syntmp-tmp-1813 (apply (lambda (syntmp-k-1814 syntmp-filename-1815) (let ((syntmp-fn-1816 (syntax-object->datum syntmp-filename-1815))) ((lambda (syntmp-tmp-1817) ((lambda (syntmp-tmp-1818) (if syntmp-tmp-1818 (apply (lambda (syntmp-exp-1819) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1819)) syntmp-tmp-1818) (syntax-error syntmp-tmp-1817))) (syntax-dispatch syntmp-tmp-1817 (quote each-any)))) (syntmp-read-file-1806 syntmp-fn-1816 syntmp-k-1814)))) syntmp-tmp-1813) (syntax-error syntmp-tmp-1812))) (syntax-dispatch syntmp-tmp-1812 (quote (any any))))) syntmp-x-1805)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1836) ((lambda (syntmp-tmp-1837) ((lambda (syntmp-tmp-1838) (if syntmp-tmp-1838 (apply (lambda (syntmp-_-1839 syntmp-e-1840) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1840))) syntmp-tmp-1838) (syntax-error syntmp-tmp-1837))) (syntax-dispatch syntmp-tmp-1837 (quote (any any))))) syntmp-x-1836))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1846) ((lambda (syntmp-tmp-1847) ((lambda (syntmp-tmp-1848) (if syntmp-tmp-1848 (apply (lambda (syntmp-_-1849 syntmp-e-1850) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1850))) syntmp-tmp-1848) (syntax-error syntmp-tmp-1847))) (syntax-dispatch syntmp-tmp-1847 (quote (any any))))) syntmp-x-1846))) -(install-global-transformer (quote case) (lambda (syntmp-x-1856) ((lambda (syntmp-tmp-1857) ((lambda (syntmp-tmp-1858) (if syntmp-tmp-1858 (apply (lambda (syntmp-_-1859 syntmp-e-1860 syntmp-m1-1861 syntmp-m2-1862) ((lambda (syntmp-tmp-1863) ((lambda (syntmp-body-1864) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1860)) syntmp-body-1864)) syntmp-tmp-1863)) (let syntmp-f-1865 ((syntmp-clause-1866 syntmp-m1-1861) (syntmp-clauses-1867 syntmp-m2-1862)) (if (null? syntmp-clauses-1867) ((lambda (syntmp-tmp-1869) ((lambda (syntmp-tmp-1870) (if syntmp-tmp-1870 (apply (lambda (syntmp-e1-1871 syntmp-e2-1872) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1871 syntmp-e2-1872))) syntmp-tmp-1870) ((lambda (syntmp-tmp-1874) (if syntmp-tmp-1874 (apply (lambda (syntmp-k-1875 syntmp-e1-1876 syntmp-e2-1877) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1875)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1876 syntmp-e2-1877)))) syntmp-tmp-1874) ((lambda (syntmp-_-1880) (syntax-error syntmp-x-1856)) syntmp-tmp-1869))) (syntax-dispatch syntmp-tmp-1869 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1869 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1866) ((lambda (syntmp-tmp-1881) ((lambda (syntmp-rest-1882) ((lambda (syntmp-tmp-1883) ((lambda (syntmp-tmp-1884) (if syntmp-tmp-1884 (apply (lambda (syntmp-k-1885 syntmp-e1-1886 syntmp-e2-1887) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1885)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1886 syntmp-e2-1887)) syntmp-rest-1882)) syntmp-tmp-1884) ((lambda (syntmp-_-1890) (syntax-error syntmp-x-1856)) syntmp-tmp-1883))) (syntax-dispatch syntmp-tmp-1883 (quote (each-any any . each-any))))) syntmp-clause-1866)) syntmp-tmp-1881)) (syntmp-f-1865 (car syntmp-clauses-1867) (cdr syntmp-clauses-1867))))))) syntmp-tmp-1858) (syntax-error syntmp-tmp-1857))) (syntax-dispatch syntmp-tmp-1857 (quote (any any any . each-any))))) syntmp-x-1856))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1920) ((lambda (syntmp-tmp-1921) ((lambda (syntmp-tmp-1922) (if syntmp-tmp-1922 (apply (lambda (syntmp-_-1923 syntmp-e-1924) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1924)) (list (cons syntmp-_-1923 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1924 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1922) (syntax-error syntmp-tmp-1921))) (syntax-dispatch syntmp-tmp-1921 (quote (any any))))) syntmp-x-1920))) +(eval-when (compile) (set-current-module (resolve-module (quote (guile))))) +(if #f #f) +(letrec ((and-map*151 (lambda (f191 first190 . rest189) (let ((t192 (null? first190))) (if t192 t192 (if (null? rest189) (letrec ((andmap193 (lambda (first194) (let ((x195 (car first194)) (first196 (cdr first194))) (if (null? first196) (f191 x195) (if (f191 x195) (andmap193 first196) #f)))))) (andmap193 first190)) (letrec ((andmap197 (lambda (first198 rest199) (let ((x200 (car first198)) (xr201 (map car rest199)) (first202 (cdr first198)) (rest203 (map cdr rest199))) (if (null? first202) (apply f191 (cons x200 xr201)) (if (apply f191 (cons x200 xr201)) (andmap197 first202 rest203) #f)))))) (andmap197 first190 rest189)))))))) (letrec ((lambda-var-list296 (lambda (vars420) (letrec ((lvl421 (lambda (vars422 ls423 w424) (if (pair? vars422) (lvl421 (cdr vars422) (cons (wrap276 (car vars422) w424 #f) ls423) w424) (if (id?248 vars422) (cons (wrap276 vars422 w424 #f) ls423) (if (null? vars422) ls423 (if (syntax-object?232 vars422) (lvl421 (syntax-object-expression233 vars422) ls423 (join-wraps267 w424 (syntax-object-wrap234 vars422))) (cons vars422 ls423)))))))) (lvl421 vars420 (quote ()) (quote (())))))) (gen-var295 (lambda (id425) (let ((id426 (if (syntax-object?232 id425) (syntax-object-expression233 id425) id425))) (gensym (symbol->string id426))))) (strip294 (lambda (x427 w428) (if (memq (quote top) (wrap-marks251 w428)) x427 (letrec ((f429 (lambda (x430) (if (syntax-object?232 x430) (strip294 (syntax-object-expression233 x430) (syntax-object-wrap234 x430)) (if (pair? x430) (let ((a431 (f429 (car x430))) (d432 (f429 (cdr x430)))) (if (if (eq? a431 (car x430)) (eq? d432 (cdr x430)) #f) x430 (cons a431 d432))) (if (vector? x430) (let ((old433 (vector->list x430))) (let ((new434 (map f429 old433))) (if (and-map*151 eq? old433 new434) x430 (list->vector new434)))) x430)))))) (f429 x427))))) (ellipsis?293 (lambda (x435) (if (nonsymbol-id?247 x435) (free-id=?271 x435 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void292 (lambda () (build-void214 #f))) (eval-local-transformer291 (lambda (expanded436 mod437) (let ((p438 (local-eval-hook211 expanded436 mod437))) (if (procedure? p438) p438 (syntax-violation #f "nonprocedure transformer" p438))))) (chi-local-syntax290 (lambda (rec?439 e440 r441 w442 s443 mod444 k445) ((lambda (tmp446) ((lambda (tmp447) (if tmp447 (apply (lambda (_448 id449 val450 e1451 e2452) (let ((ids453 id449)) (if (not (valid-bound-ids?273 ids453)) (syntax-violation #f "duplicate bound keyword" e440) (let ((labels455 (gen-labels254 ids453))) (let ((new-w456 (make-binding-wrap265 ids453 labels455 w442))) (k445 (cons e1451 e2452) (extend-env242 labels455 (let ((w458 (if rec?439 new-w456 w442)) (trans-r459 (macros-only-env244 r441))) (map (lambda (x460) (cons (quote macro) (eval-local-transformer291 (chi284 x460 trans-r459 w458 mod444) mod444))) val450)) r441) new-w456 s443 mod444)))))) tmp447) ((lambda (_462) (syntax-violation #f "bad local syntax definition" (source-wrap277 e440 w442 s443 mod444))) tmp446))) ($sc-dispatch tmp446 (quote (any #(each (any any)) any . each-any))))) e440))) (chi-lambda-clause289 (lambda (e463 docstring464 c465 r466 w467 mod468 k469) ((lambda (tmp470) ((lambda (tmp471) (if (if tmp471 (apply (lambda (args472 doc473 e1474 e2475) (if (string? (syntax->datum doc473)) (not docstring464) #f)) tmp471) #f) (apply (lambda (args476 doc477 e1478 e2479) (chi-lambda-clause289 e463 doc477 (cons args476 (cons e1478 e2479)) r466 w467 mod468 k469)) tmp471) ((lambda (tmp481) (if tmp481 (apply (lambda (id482 e1483 e2484) (let ((ids485 id482)) (if (not (valid-bound-ids?273 ids485)) (syntax-violation (quote lambda) "invalid parameter list" e463) (let ((labels487 (gen-labels254 ids485)) (new-vars488 (map gen-var295 ids485))) (k469 (map syntax->datum ids485) new-vars488 (if docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1483 e2484) e463 (extend-var-env243 labels487 new-vars488 r466) (make-binding-wrap265 ids485 labels487 w467) mod468)))))) tmp481) ((lambda (tmp490) (if tmp490 (apply (lambda (ids491 e1492 e2493) (let ((old-ids494 (lambda-var-list296 ids491))) (if (not (valid-bound-ids?273 old-ids494)) (syntax-violation (quote lambda) "invalid parameter list" e463) (let ((labels495 (gen-labels254 old-ids494)) (new-vars496 (map gen-var295 old-ids494))) (k469 (letrec ((f497 (lambda (ls1498 ls2499) (if (null? ls1498) (syntax->datum ls2499) (f497 (cdr ls1498) (cons (syntax->datum (car ls1498)) ls2499)))))) (f497 (cdr old-ids494) (car old-ids494))) (letrec ((f500 (lambda (ls1501 ls2502) (if (null? ls1501) ls2502 (f500 (cdr ls1501) (cons (car ls1501) ls2502)))))) (f500 (cdr new-vars496) (car new-vars496))) (if docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1492 e2493) e463 (extend-var-env243 labels495 new-vars496 r466) (make-binding-wrap265 old-ids494 labels495 w467) mod468)))))) tmp490) ((lambda (_504) (syntax-violation (quote lambda) "bad lambda" e463)) tmp470))) ($sc-dispatch tmp470 (quote (any any . each-any)))))) ($sc-dispatch tmp470 (quote (each-any any . each-any)))))) ($sc-dispatch tmp470 (quote (any any any . each-any))))) c465))) (chi-body288 (lambda (body505 outer-form506 r507 w508 mod509) (let ((r510 (cons (quote ("placeholder" placeholder)) r507))) (let ((ribcage511 (make-ribcage255 (quote ()) (quote ()) (quote ())))) (let ((w512 (make-wrap250 (wrap-marks251 w508) (cons ribcage511 (wrap-subst252 w508))))) (letrec ((parse513 (lambda (body514 ids515 labels516 var-ids517 vars518 vals519 bindings520) (if (null? body514) (syntax-violation #f "no expressions in body" outer-form506) (let ((e522 (cdar body514)) (er523 (caar body514))) (call-with-values (lambda () (syntax-type282 e522 er523 (quote (())) (source-annotation239 er523) ribcage511 mod509)) (lambda (type524 value525 e526 w527 s528 mod529) (if (memv type524 (quote (define-form))) (let ((id530 (wrap276 value525 w527 mod529)) (label531 (gen-label253))) (let ((var532 (gen-var295 id530))) (begin (extend-ribcage!264 ribcage511 id530 label531) (parse513 (cdr body514) (cons id530 ids515) (cons label531 labels516) (cons id530 var-ids517) (cons var532 vars518) (cons (cons er523 (wrap276 e526 w527 mod529)) vals519) (cons (cons (quote lexical) var532) bindings520))))) (if (memv type524 (quote (define-syntax-form))) (let ((id533 (wrap276 value525 w527 mod529)) (label534 (gen-label253))) (begin (extend-ribcage!264 ribcage511 id533 label534) (parse513 (cdr body514) (cons id533 ids515) (cons label534 labels516) var-ids517 vars518 vals519 (cons (cons (quote macro) (cons er523 (wrap276 e526 w527 mod529))) bindings520)))) (if (memv type524 (quote (begin-form))) ((lambda (tmp535) ((lambda (tmp536) (if tmp536 (apply (lambda (_537 e1538) (parse513 (letrec ((f539 (lambda (forms540) (if (null? forms540) (cdr body514) (cons (cons er523 (wrap276 (car forms540) w527 mod529)) (f539 (cdr forms540))))))) (f539 e1538)) ids515 labels516 var-ids517 vars518 vals519 bindings520)) tmp536) (syntax-violation #f "source expression failed to match any pattern" tmp535))) ($sc-dispatch tmp535 (quote (any . each-any))))) e526) (if (memv type524 (quote (local-syntax-form))) (chi-local-syntax290 value525 e526 er523 w527 s528 mod529 (lambda (forms542 er543 w544 s545 mod546) (parse513 (letrec ((f547 (lambda (forms548) (if (null? forms548) (cdr body514) (cons (cons er543 (wrap276 (car forms548) w544 mod546)) (f547 (cdr forms548))))))) (f547 forms542)) ids515 labels516 var-ids517 vars518 vals519 bindings520))) (if (null? ids515) (build-sequence227 #f (map (lambda (x549) (chi284 (cdr x549) (car x549) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr body514)))) (begin (if (not (valid-bound-ids?273 ids515)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form506)) (letrec ((loop550 (lambda (bs551 er-cache552 r-cache553) (if (not (null? bs551)) (let ((b554 (car bs551))) (if (eq? (car b554) (quote macro)) (let ((er555 (cadr b554))) (let ((r-cache556 (if (eq? er555 er-cache552) r-cache553 (macros-only-env244 er555)))) (begin (set-cdr! b554 (eval-local-transformer291 (chi284 (cddr b554) r-cache556 (quote (())) mod529) mod529)) (loop550 (cdr bs551) er555 r-cache556)))) (loop550 (cdr bs551) er-cache552 r-cache553))))))) (loop550 bindings520 #f #f)) (set-cdr! r510 (extend-env242 labels516 bindings520 (cdr r510))) (build-letrec230 #f (map syntax->datum var-ids517) vars518 (map (lambda (x557) (chi284 (cdr x557) (car x557) (quote (())) mod529)) vals519) (build-sequence227 #f (map (lambda (x558) (chi284 (cdr x558) (car x558) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr body514)))))))))))))))))) (parse513 (map (lambda (x521) (cons r510 (wrap276 x521 w512 mod509))) body505) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro287 (lambda (p559 e560 r561 w562 rib563 mod564) (letrec ((rebuild-macro-output565 (lambda (x566 m567) (if (pair? x566) (cons (rebuild-macro-output565 (car x566) m567) (rebuild-macro-output565 (cdr x566) m567)) (if (syntax-object?232 x566) (let ((w568 (syntax-object-wrap234 x566))) (let ((ms569 (wrap-marks251 w568)) (s570 (wrap-subst252 w568))) (if (if (pair? ms569) (eq? (car ms569) #f) #f) (make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cdr ms569) (if rib563 (cons rib563 (cdr s570)) (cdr s570))) (syntax-object-module235 x566)) (make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cons m567 ms569) (if rib563 (cons rib563 (cons (quote shift) s570)) (cons (quote shift) s570))) (let ((pmod571 (procedure-module p559))) (if pmod571 (cons (quote hygiene) (module-name pmod571)) (quote (hygiene guile)))))))) (if (vector? x566) (let ((n572 (vector-length x566))) (let ((v573 (make-vector n572))) (letrec ((loop574 (lambda (i575) (if (fx=208 i575 n572) (begin (if #f #f) v573) (begin (vector-set! v573 i575 (rebuild-macro-output565 (vector-ref x566 i575) m567)) (loop574 (fx+206 i575 1))))))) (loop574 0)))) (if (symbol? x566) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap277 e560 w562 s mod564) x566) x566))))))) (rebuild-macro-output565 (p559 (wrap276 e560 (anti-mark263 w562) mod564)) (string #\m))))) (chi-application286 (lambda (x576 e577 r578 w579 s580 mod581) ((lambda (tmp582) ((lambda (tmp583) (if tmp583 (apply (lambda (e0584 e1585) (build-application215 s580 x576 (map (lambda (e586) (chi284 e586 r578 w579 mod581)) e1585))) tmp583) (syntax-violation #f "source expression failed to match any pattern" tmp582))) ($sc-dispatch tmp582 (quote (any . each-any))))) e577))) (chi-expr285 (lambda (type588 value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote (lexical))) (build-lexical-reference217 (quote value) s593 e590 value589) (if (memv type588 (quote (core external-macro))) (value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote (module-ref))) (call-with-values (lambda () (value589 e590)) (lambda (id595 mod596) (build-global-reference220 s593 id595 mod596))) (if (memv type588 (quote (lexical-call))) (chi-application286 (build-lexical-reference217 (quote fun) (source-annotation239 (car e590)) (car e590) value589) e590 r591 w592 s593 mod594) (if (memv type588 (quote (global-call))) (chi-application286 (build-global-reference220 (source-annotation239 (car e590)) value589 (if (syntax-object?232 (car e590)) (syntax-object-module235 (car e590)) mod594)) e590 r591 w592 s593 mod594) (if (memv type588 (quote (constant))) (build-data226 s593 (strip294 (source-wrap277 e590 w592 s593 mod594) (quote (())))) (if (memv type588 (quote (global))) (build-global-reference220 s593 value589 mod594) (if (memv type588 (quote (call))) (chi-application286 (chi284 (car e590) r591 w592 mod594) e590 r591 w592 s593 mod594) (if (memv type588 (quote (begin-form))) ((lambda (tmp597) ((lambda (tmp598) (if tmp598 (apply (lambda (_599 e1600 e2601) (chi-sequence278 (cons e1600 e2601) r591 w592 s593 mod594)) tmp598) (syntax-violation #f "source expression failed to match any pattern" tmp597))) ($sc-dispatch tmp597 (quote (any any . each-any))))) e590) (if (memv type588 (quote (local-syntax-form))) (chi-local-syntax290 value589 e590 r591 w592 s593 mod594 chi-sequence278) (if (memv type588 (quote (eval-when-form))) ((lambda (tmp603) ((lambda (tmp604) (if tmp604 (apply (lambda (_605 x606 e1607 e2608) (let ((when-list609 (chi-when-list281 e590 x606 w592))) (if (memq (quote eval) when-list609) (chi-sequence278 (cons e1607 e2608) r591 w592 s593 mod594) (chi-void292)))) tmp604) (syntax-violation #f "source expression failed to match any pattern" tmp603))) ($sc-dispatch tmp603 (quote (any each-any any . each-any))))) e590) (if (memv type588 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e590 (wrap276 value589 w592 mod594)) (if (memv type588 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap277 e590 w592 s593 mod594)) (if (memv type588 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap277 e590 w592 s593 mod594)) (syntax-violation #f "unexpected syntax" (source-wrap277 e590 w592 s593 mod594)))))))))))))))))) (chi284 (lambda (e612 r613 w614 mod615) (call-with-values (lambda () (syntax-type282 e612 r613 w614 (source-annotation239 e612) #f mod615)) (lambda (type616 value617 e618 w619 s620 mod621) (chi-expr285 type616 value617 e618 r613 w619 s620 mod621))))) (chi-top283 (lambda (e622 r623 w624 m625 esew626 mod627) (call-with-values (lambda () (syntax-type282 e622 r623 w624 (source-annotation239 e622) #f mod627)) (lambda (type635 value636 e637 w638 s639 mod640) (if (memv type635 (quote (begin-form))) ((lambda (tmp641) ((lambda (tmp642) (if tmp642 (apply (lambda (_643) (chi-void292)) tmp642) ((lambda (tmp644) (if tmp644 (apply (lambda (_645 e1646 e2647) (chi-top-sequence279 (cons e1646 e2647) r623 w638 s639 m625 esew626 mod640)) tmp644) (syntax-violation #f "source expression failed to match any pattern" tmp641))) ($sc-dispatch tmp641 (quote (any any . each-any)))))) ($sc-dispatch tmp641 (quote (any))))) e637) (if (memv type635 (quote (local-syntax-form))) (chi-local-syntax290 value636 e637 r623 w638 s639 mod640 (lambda (body649 r650 w651 s652 mod653) (chi-top-sequence279 body649 r650 w651 s652 m625 esew626 mod653))) (if (memv type635 (quote (eval-when-form))) ((lambda (tmp654) ((lambda (tmp655) (if tmp655 (apply (lambda (_656 x657 e1658 e2659) (let ((when-list660 (chi-when-list281 e637 x657 w638)) (body661 (cons e1658 e2659))) (if (eq? m625 (quote e)) (if (memq (quote eval) when-list660) (chi-top-sequence279 body661 r623 w638 s639 (quote e) (quote (eval)) mod640) (chi-void292)) (if (memq (quote load) when-list660) (if (let ((t664 (memq (quote compile) when-list660))) (if t664 t664 (if (eq? m625 (quote c&e)) (memq (quote eval) when-list660) #f))) (chi-top-sequence279 body661 r623 w638 s639 (quote c&e) (quote (compile load)) mod640) (if (memq m625 (quote (c c&e))) (chi-top-sequence279 body661 r623 w638 s639 (quote c) (quote (load)) mod640) (chi-void292))) (if (let ((t665 (memq (quote compile) when-list660))) (if t665 t665 (if (eq? m625 (quote c&e)) (memq (quote eval) when-list660) #f))) (begin (top-level-eval-hook210 (chi-top-sequence279 body661 r623 w638 s639 (quote e) (quote (eval)) mod640) mod640) (chi-void292)) (chi-void292)))))) tmp655) (syntax-violation #f "source expression failed to match any pattern" tmp654))) ($sc-dispatch tmp654 (quote (any each-any any . each-any))))) e637) (if (memv type635 (quote (define-syntax-form))) (let ((n666 (id-var-name270 value636 w638)) (r667 (macros-only-env244 r623))) (if (memv m625 (quote (c))) (if (memq (quote compile) esew626) (let ((e668 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin (top-level-eval-hook210 e668 mod640) (if (memq (quote load) esew626) e668 (chi-void292)))) (if (memq (quote load) esew626) (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)) (chi-void292))) (if (memv m625 (quote (c&e))) (let ((e669 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin (top-level-eval-hook210 e669 mod640) e669)) (begin (if (memq (quote eval) esew626) (top-level-eval-hook210 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)) mod640)) (chi-void292))))) (if (memv type635 (quote (define-form))) (let ((n670 (id-var-name270 value636 w638))) (let ((type671 (binding-type240 (lookup245 n670 r623 mod640)))) (if (memv type671 (quote (global core macro module-ref))) (let ((x672 (build-global-definition223 s639 n670 (chi284 e637 r623 w638 mod640)))) (begin (if (eq? m625 (quote c&e)) (top-level-eval-hook210 x672 mod640)) x672)) (if (memv type671 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e637 (wrap276 value636 w638 mod640)) (syntax-violation #f "cannot define keyword at top level" e637 (wrap276 value636 w638 mod640)))))) (let ((x673 (chi-expr285 type635 value636 e637 r623 w638 s639 mod640))) (begin (if (eq? m625 (quote c&e)) (top-level-eval-hook210 x673 mod640)) x673))))))))))) (syntax-type282 (lambda (e674 r675 w676 s677 rib678 mod679) (if (symbol? e674) (let ((n680 (id-var-name270 e674 w676))) (let ((b681 (lookup245 n680 r675 mod679))) (let ((type682 (binding-type240 b681))) (if (memv type682 (quote (lexical))) (values type682 (binding-value241 b681) e674 w676 s677 mod679) (if (memv type682 (quote (global))) (values type682 n680 e674 w676 s677 mod679) (if (memv type682 (quote (macro))) (syntax-type282 (chi-macro287 (binding-value241 b681) e674 r675 w676 rib678 mod679) r675 (quote (())) s677 rib678 mod679) (values type682 (binding-value241 b681) e674 w676 s677 mod679))))))) (if (pair? e674) (let ((first683 (car e674))) (if (id?248 first683) (let ((n684 (id-var-name270 first683 w676))) (let ((b685 (lookup245 n684 r675 (let ((t686 (if (syntax-object?232 first683) (syntax-object-module235 first683) #f))) (if t686 t686 mod679))))) (let ((type687 (binding-type240 b685))) (if (memv type687 (quote (lexical))) (values (quote lexical-call) (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (global))) (values (quote global-call) n684 e674 w676 s677 mod679) (if (memv type687 (quote (macro))) (syntax-type282 (chi-macro287 (binding-value241 b685) e674 r675 w676 rib678 mod679) r675 (quote (())) s677 rib678 mod679) (if (memv type687 (quote (core external-macro module-ref))) (values type687 (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (begin))) (values (quote begin-form) #f e674 w676 s677 mod679) (if (memv type687 (quote (eval-when))) (values (quote eval-when-form) #f e674 w676 s677 mod679) (if (memv type687 (quote (define))) ((lambda (tmp688) ((lambda (tmp689) (if (if tmp689 (apply (lambda (_690 name691 val692) (id?248 name691)) tmp689) #f) (apply (lambda (_693 name694 val695) (values (quote define-form) name694 val695 w676 s677 mod679)) tmp689) ((lambda (tmp696) (if (if tmp696 (apply (lambda (_697 name698 args699 e1700 e2701) (if (id?248 name698) (valid-bound-ids?273 (lambda-var-list296 args699)) #f)) tmp696) #f) (apply (lambda (_702 name703 args704 e1705 e2706) (values (quote define-form) (wrap276 name703 w676 mod679) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap276 (cons args704 (cons e1705 e2706)) w676 mod679)) (quote (())) s677 mod679)) tmp696) ((lambda (tmp708) (if (if tmp708 (apply (lambda (_709 name710) (id?248 name710)) tmp708) #f) (apply (lambda (_711 name712) (values (quote define-form) (wrap276 name712 w676 mod679) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s677 mod679)) tmp708) (syntax-violation #f "source expression failed to match any pattern" tmp688))) ($sc-dispatch tmp688 (quote (any any)))))) ($sc-dispatch tmp688 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp688 (quote (any any any))))) e674) (if (memv type687 (quote (define-syntax))) ((lambda (tmp713) ((lambda (tmp714) (if (if tmp714 (apply (lambda (_715 name716 val717) (id?248 name716)) tmp714) #f) (apply (lambda (_718 name719 val720) (values (quote define-syntax-form) name719 val720 w676 s677 mod679)) tmp714) (syntax-violation #f "source expression failed to match any pattern" tmp713))) ($sc-dispatch tmp713 (quote (any any any))))) e674) (values (quote call) #f e674 w676 s677 mod679))))))))))))) (values (quote call) #f e674 w676 s677 mod679))) (if (syntax-object?232 e674) (syntax-type282 (syntax-object-expression233 e674) r675 (join-wraps267 w676 (syntax-object-wrap234 e674)) s677 rib678 (let ((t721 (syntax-object-module235 e674))) (if t721 t721 mod679))) (if (self-evaluating? e674) (values (quote constant) #f e674 w676 s677 mod679) (values (quote other) #f e674 w676 s677 mod679))))))) (chi-when-list281 (lambda (e722 when-list723 w724) (letrec ((f725 (lambda (when-list726 situations727) (if (null? when-list726) situations727 (f725 (cdr when-list726) (cons (let ((x728 (car when-list726))) (if (free-id=?271 x728 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?271 x728 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?271 x728 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e722 (wrap276 x728 w724 #f)))))) situations727)))))) (f725 when-list723 (quote ()))))) (chi-install-global280 (lambda (name729 e730) (build-global-definition223 #f name729 (if (let ((v731 (module-variable (current-module) name729))) (if v731 (if (variable-bound? v731) (if (macro? (variable-ref v731)) (not (eq? (macro-type (variable-ref v731)) (quote syncase-macro))) #f) #f) #f)) (build-application215 #f (build-primref225 #f (quote make-extended-syncase-macro)) (list (build-application215 #f (build-primref225 #f (quote module-ref)) (list (build-application215 #f (build-primref225 #f (quote current-module)) (quote ())) (build-data226 #f name729))) (build-data226 #f (quote macro)) e730)) (build-application215 #f (build-primref225 #f (quote make-syncase-macro)) (list (build-data226 #f (quote macro)) e730)))))) (chi-top-sequence279 (lambda (body732 r733 w734 s735 m736 esew737 mod738) (build-sequence227 s735 (letrec ((dobody739 (lambda (body740 r741 w742 m743 esew744 mod745) (if (null? body740) (quote ()) (let ((first746 (chi-top283 (car body740) r741 w742 m743 esew744 mod745))) (cons first746 (dobody739 (cdr body740) r741 w742 m743 esew744 mod745))))))) (dobody739 body732 r733 w734 m736 esew737 mod738))))) (chi-sequence278 (lambda (body747 r748 w749 s750 mod751) (build-sequence227 s750 (letrec ((dobody752 (lambda (body753 r754 w755 mod756) (if (null? body753) (quote ()) (let ((first757 (chi284 (car body753) r754 w755 mod756))) (cons first757 (dobody752 (cdr body753) r754 w755 mod756))))))) (dobody752 body747 r748 w749 mod751))))) (source-wrap277 (lambda (x758 w759 s760 defmod761) (begin (if (if s760 (pair? x758) #f) (set-source-properties! x758 s760)) (wrap276 x758 w759 defmod761)))) (wrap276 (lambda (x762 w763 defmod764) (if (if (null? (wrap-marks251 w763)) (null? (wrap-subst252 w763)) #f) x762 (if (syntax-object?232 x762) (make-syntax-object231 (syntax-object-expression233 x762) (join-wraps267 w763 (syntax-object-wrap234 x762)) (syntax-object-module235 x762)) (if (null? x762) x762 (make-syntax-object231 x762 w763 defmod764)))))) (bound-id-member?275 (lambda (x765 list766) (if (not (null? list766)) (let ((t767 (bound-id=?272 x765 (car list766)))) (if t767 t767 (bound-id-member?275 x765 (cdr list766)))) #f))) (distinct-bound-ids?274 (lambda (ids768) (letrec ((distinct?769 (lambda (ids770) (let ((t771 (null? ids770))) (if t771 t771 (if (not (bound-id-member?275 (car ids770) (cdr ids770))) (distinct?769 (cdr ids770)) #f)))))) (distinct?769 ids768)))) (valid-bound-ids?273 (lambda (ids772) (if (letrec ((all-ids?773 (lambda (ids774) (let ((t775 (null? ids774))) (if t775 t775 (if (id?248 (car ids774)) (all-ids?773 (cdr ids774)) #f)))))) (all-ids?773 ids772)) (distinct-bound-ids?274 ids772) #f))) (bound-id=?272 (lambda (i776 j777) (if (if (syntax-object?232 i776) (syntax-object?232 j777) #f) (if (eq? (syntax-object-expression233 i776) (syntax-object-expression233 j777)) (same-marks?269 (wrap-marks251 (syntax-object-wrap234 i776)) (wrap-marks251 (syntax-object-wrap234 j777))) #f) (eq? i776 j777)))) (free-id=?271 (lambda (i778 j779) (if (eq? (let ((x780 i778)) (if (syntax-object?232 x780) (syntax-object-expression233 x780) x780)) (let ((x781 j779)) (if (syntax-object?232 x781) (syntax-object-expression233 x781) x781))) (eq? (id-var-name270 i778 (quote (()))) (id-var-name270 j779 (quote (())))) #f))) (id-var-name270 (lambda (id782 w783) (letrec ((search-vector-rib786 (lambda (sym792 subst793 marks794 symnames795 ribcage796) (let ((n797 (vector-length symnames795))) (letrec ((f798 (lambda (i799) (if (fx=208 i799 n797) (search784 sym792 (cdr subst793) marks794) (if (if (eq? (vector-ref symnames795 i799) sym792) (same-marks?269 marks794 (vector-ref (ribcage-marks258 ribcage796) i799)) #f) (values (vector-ref (ribcage-labels259 ribcage796) i799) marks794) (f798 (fx+206 i799 1))))))) (f798 0))))) (search-list-rib785 (lambda (sym800 subst801 marks802 symnames803 ribcage804) (letrec ((f805 (lambda (symnames806 i807) (if (null? symnames806) (search784 sym800 (cdr subst801) marks802) (if (if (eq? (car symnames806) sym800) (same-marks?269 marks802 (list-ref (ribcage-marks258 ribcage804) i807)) #f) (values (list-ref (ribcage-labels259 ribcage804) i807) marks802) (f805 (cdr symnames806) (fx+206 i807 1))))))) (f805 symnames803 0)))) (search784 (lambda (sym808 subst809 marks810) (if (null? subst809) (values #f marks810) (let ((fst811 (car subst809))) (if (eq? fst811 (quote shift)) (search784 sym808 (cdr subst809) (cdr marks810)) (let ((symnames812 (ribcage-symnames257 fst811))) (if (vector? symnames812) (search-vector-rib786 sym808 subst809 marks810 symnames812 fst811) (search-list-rib785 sym808 subst809 marks810 symnames812 fst811))))))))) (if (symbol? id782) (let ((t813 (call-with-values (lambda () (search784 id782 (wrap-subst252 w783) (wrap-marks251 w783))) (lambda (x815 . ignore814) x815)))) (if t813 t813 id782)) (if (syntax-object?232 id782) (let ((id816 (syntax-object-expression233 id782)) (w1817 (syntax-object-wrap234 id782))) (let ((marks818 (join-marks268 (wrap-marks251 w783) (wrap-marks251 w1817)))) (call-with-values (lambda () (search784 id816 (wrap-subst252 w783) marks818)) (lambda (new-id819 marks820) (let ((t821 new-id819)) (if t821 t821 (let ((t822 (call-with-values (lambda () (search784 id816 (wrap-subst252 w1817) marks820)) (lambda (x824 . ignore823) x824)))) (if t822 t822 id816)))))))) (syntax-violation (quote id-var-name) "invalid id" id782)))))) (same-marks?269 (lambda (x825 y826) (let ((t827 (eq? x825 y826))) (if t827 t827 (if (not (null? x825)) (if (not (null? y826)) (if (eq? (car x825) (car y826)) (same-marks?269 (cdr x825) (cdr y826)) #f) #f) #f))))) (join-marks268 (lambda (m1828 m2829) (smart-append266 m1828 m2829))) (join-wraps267 (lambda (w1830 w2831) (let ((m1832 (wrap-marks251 w1830)) (s1833 (wrap-subst252 w1830))) (if (null? m1832) (if (null? s1833) w2831 (make-wrap250 (wrap-marks251 w2831) (smart-append266 s1833 (wrap-subst252 w2831)))) (make-wrap250 (smart-append266 m1832 (wrap-marks251 w2831)) (smart-append266 s1833 (wrap-subst252 w2831))))))) (smart-append266 (lambda (m1834 m2835) (if (null? m2835) m1834 (append m1834 m2835)))) (make-binding-wrap265 (lambda (ids836 labels837 w838) (if (null? ids836) w838 (make-wrap250 (wrap-marks251 w838) (cons (let ((labelvec839 (list->vector labels837))) (let ((n840 (vector-length labelvec839))) (let ((symnamevec841 (make-vector n840)) (marksvec842 (make-vector n840))) (begin (letrec ((f843 (lambda (ids844 i845) (if (not (null? ids844)) (call-with-values (lambda () (id-sym-name&marks249 (car ids844) w838)) (lambda (symname846 marks847) (begin (vector-set! symnamevec841 i845 symname846) (vector-set! marksvec842 i845 marks847) (f843 (cdr ids844) (fx+206 i845 1))))))))) (f843 ids836 0)) (make-ribcage255 symnamevec841 marksvec842 labelvec839))))) (wrap-subst252 w838)))))) (extend-ribcage!264 (lambda (ribcage848 id849 label850) (begin (set-ribcage-symnames!260 ribcage848 (cons (syntax-object-expression233 id849) (ribcage-symnames257 ribcage848))) (set-ribcage-marks!261 ribcage848 (cons (wrap-marks251 (syntax-object-wrap234 id849)) (ribcage-marks258 ribcage848))) (set-ribcage-labels!262 ribcage848 (cons label850 (ribcage-labels259 ribcage848)))))) (anti-mark263 (lambda (w851) (make-wrap250 (cons #f (wrap-marks251 w851)) (cons (quote shift) (wrap-subst252 w851))))) (set-ribcage-labels!262 (lambda (x852 update853) (vector-set! x852 3 update853))) (set-ribcage-marks!261 (lambda (x854 update855) (vector-set! x854 2 update855))) (set-ribcage-symnames!260 (lambda (x856 update857) (vector-set! x856 1 update857))) (ribcage-labels259 (lambda (x858) (vector-ref x858 3))) (ribcage-marks258 (lambda (x859) (vector-ref x859 2))) (ribcage-symnames257 (lambda (x860) (vector-ref x860 1))) (ribcage?256 (lambda (x861) (if (vector? x861) (if (= (vector-length x861) 4) (eq? (vector-ref x861 0) (quote ribcage)) #f) #f))) (make-ribcage255 (lambda (symnames862 marks863 labels864) (vector (quote ribcage) symnames862 marks863 labels864))) (gen-labels254 (lambda (ls865) (if (null? ls865) (quote ()) (cons (gen-label253) (gen-labels254 (cdr ls865)))))) (gen-label253 (lambda () (string #\i))) (wrap-subst252 cdr) (wrap-marks251 car) (make-wrap250 cons) (id-sym-name&marks249 (lambda (x866 w867) (if (syntax-object?232 x866) (values (syntax-object-expression233 x866) (join-marks268 (wrap-marks251 w867) (wrap-marks251 (syntax-object-wrap234 x866)))) (values x866 (wrap-marks251 w867))))) (id?248 (lambda (x868) (if (symbol? x868) #t (if (syntax-object?232 x868) (symbol? (syntax-object-expression233 x868)) #f)))) (nonsymbol-id?247 (lambda (x869) (if (syntax-object?232 x869) (symbol? (syntax-object-expression233 x869)) #f))) (global-extend246 (lambda (type870 sym871 val872) (put-global-definition-hook212 sym871 type870 val872))) (lookup245 (lambda (x873 r874 mod875) (let ((t876 (assq x873 r874))) (if t876 (cdr t876) (if (symbol? x873) (let ((t877 (get-global-definition-hook213 x873 mod875))) (if t877 t877 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env244 (lambda (r878) (if (null? r878) (quote ()) (let ((a879 (car r878))) (if (eq? (cadr a879) (quote macro)) (cons a879 (macros-only-env244 (cdr r878))) (macros-only-env244 (cdr r878))))))) (extend-var-env243 (lambda (labels880 vars881 r882) (if (null? labels880) r882 (extend-var-env243 (cdr labels880) (cdr vars881) (cons (cons (car labels880) (cons (quote lexical) (car vars881))) r882))))) (extend-env242 (lambda (labels883 bindings884 r885) (if (null? labels883) r885 (extend-env242 (cdr labels883) (cdr bindings884) (cons (cons (car labels883) (car bindings884)) r885))))) (binding-value241 cdr) (binding-type240 car) (source-annotation239 (lambda (x886) (if (syntax-object?232 x886) (source-annotation239 (syntax-object-expression233 x886)) (if (pair? x886) (let ((props887 (source-properties x886))) (if (pair? props887) props887 #f)) #f)))) (set-syntax-object-module!238 (lambda (x888 update889) (vector-set! x888 3 update889))) (set-syntax-object-wrap!237 (lambda (x890 update891) (vector-set! x890 2 update891))) (set-syntax-object-expression!236 (lambda (x892 update893) (vector-set! x892 1 update893))) (syntax-object-module235 (lambda (x894) (vector-ref x894 3))) (syntax-object-wrap234 (lambda (x895) (vector-ref x895 2))) (syntax-object-expression233 (lambda (x896) (vector-ref x896 1))) (syntax-object?232 (lambda (x897) (if (vector? x897) (if (= (vector-length x897) 4) (eq? (vector-ref x897 0) (quote syntax-object)) #f) #f))) (make-syntax-object231 (lambda (expression898 wrap899 module900) (vector (quote syntax-object) expression898 wrap899 module900))) (build-letrec230 (lambda (src901 ids902 vars903 val-exps904 body-exp905) (if (null? vars903) body-exp905 (let ((atom-key906 (fluid-ref *mode*205))) (if (memv atom-key906 (quote (c))) (begin (for-each maybe-name-value!222 ids902 val-exps904) ((@ (language tree-il) make-letrec) src901 ids902 vars903 val-exps904 body-exp905)) (list (quote letrec) (map list vars903 val-exps904) body-exp905)))))) (build-named-let229 (lambda (src907 ids908 vars909 val-exps910 body-exp911) (let ((f912 (car vars909)) (f-name913 (car ids908)) (vars914 (cdr vars909)) (ids915 (cdr ids908))) (let ((atom-key916 (fluid-ref *mode*205))) (if (memv atom-key916 (quote (c))) (let ((proc917 (build-lambda224 src907 ids915 vars914 #f body-exp911))) (begin (maybe-name-value!222 f-name913 proc917) (for-each maybe-name-value!222 ids915 val-exps910) ((@ (language tree-il) make-letrec) src907 (list f-name913) (list f912) (list proc917) (build-application215 src907 (build-lexical-reference217 (quote fun) src907 f-name913 f912) val-exps910)))) (list (quote let) f912 (map list vars914 val-exps910) body-exp911)))))) (build-let228 (lambda (src918 ids919 vars920 val-exps921 body-exp922) (if (null? vars920) body-exp922 (let ((atom-key923 (fluid-ref *mode*205))) (if (memv atom-key923 (quote (c))) (begin (for-each maybe-name-value!222 ids919 val-exps921) ((@ (language tree-il) make-let) src918 ids919 vars920 val-exps921 body-exp922)) (list (quote let) (map list vars920 val-exps921) body-exp922)))))) (build-sequence227 (lambda (src924 exps925) (if (null? (cdr exps925)) (car exps925) (let ((atom-key926 (fluid-ref *mode*205))) (if (memv atom-key926 (quote (c))) ((@ (language tree-il) make-sequence) src924 exps925) (cons (quote begin) exps925)))))) (build-data226 (lambda (src927 exp928) (let ((atom-key929 (fluid-ref *mode*205))) (if (memv atom-key929 (quote (c))) ((@ (language tree-il) make-const) src927 exp928) (if (if (self-evaluating? exp928) (not (vector? exp928)) #f) exp928 (list (quote quote) exp928)))))) (build-primref225 (lambda (src930 name931) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key932 (fluid-ref *mode*205))) (if (memv atom-key932 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src930 name931) name931)) (let ((atom-key933 (fluid-ref *mode*205))) (if (memv atom-key933 (quote (c))) ((@ (language tree-il) make-module-ref) src930 (quote (guile)) name931 #f) (list (quote @@) (quote (guile)) name931)))))) (build-lambda224 (lambda (src934 ids935 vars936 docstring937 exp938) (let ((atom-key939 (fluid-ref *mode*205))) (if (memv atom-key939 (quote (c))) ((@ (language tree-il) make-lambda) src934 ids935 vars936 (if docstring937 (list (cons (quote documentation) docstring937)) (quote ())) exp938) (cons (quote lambda) (cons vars936 (append (if docstring937 (list docstring937) (quote ())) (list exp938)))))))) (build-global-definition223 (lambda (source940 var941 exp942) (let ((atom-key943 (fluid-ref *mode*205))) (if (memv atom-key943 (quote (c))) (begin (maybe-name-value!222 var941 exp942) ((@ (language tree-il) make-toplevel-define) source940 var941 exp942)) (list (quote define) var941 exp942))))) (maybe-name-value!222 (lambda (name944 val945) (if ((@ (language tree-il) lambda?) val945) (let ((meta946 ((@ (language tree-il) lambda-meta) val945))) (if (not (assq (quote name) meta946)) ((setter (@ (language tree-il) lambda-meta)) val945 (acons (quote name) name944 meta946))))))) (build-global-assignment221 (lambda (source947 var948 exp949 mod950) (analyze-variable219 mod950 var948 (lambda (mod951 var952 public?953) (let ((atom-key954 (fluid-ref *mode*205))) (if (memv atom-key954 (quote (c))) ((@ (language tree-il) make-module-set) source947 mod951 var952 public?953 exp949) (list (quote set!) (list (if public?953 (quote @) (quote @@)) mod951 var952) exp949)))) (lambda (var955) (let ((atom-key956 (fluid-ref *mode*205))) (if (memv atom-key956 (quote (c))) ((@ (language tree-il) make-toplevel-set) source947 var955 exp949) (list (quote set!) var955 exp949))))))) (build-global-reference220 (lambda (source957 var958 mod959) (analyze-variable219 mod959 var958 (lambda (mod960 var961 public?962) (let ((atom-key963 (fluid-ref *mode*205))) (if (memv atom-key963 (quote (c))) ((@ (language tree-il) make-module-ref) source957 mod960 var961 public?962) (list (if public?962 (quote @) (quote @@)) mod960 var961)))) (lambda (var964) (let ((atom-key965 (fluid-ref *mode*205))) (if (memv atom-key965 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source957 var964) var964)))))) (analyze-variable219 (lambda (mod966 var967 modref-cont968 bare-cont969) (if (not mod966) (bare-cont969 var967) (let ((kind970 (car mod966)) (mod971 (cdr mod966))) (if (memv kind970 (quote (public))) (modref-cont968 mod971 var967 #t) (if (memv kind970 (quote (private))) (if (not (equal? mod971 (module-name (current-module)))) (modref-cont968 mod971 var967 #f) (bare-cont969 var967)) (if (memv kind970 (quote (bare))) (bare-cont969 var967) (if (memv kind970 (quote (hygiene))) (if (if (not (equal? mod971 (module-name (current-module)))) (module-variable (resolve-module mod971) var967) #f) (modref-cont968 mod971 var967 #f) (bare-cont969 var967)) (syntax-violation #f "bad module kind" var967 mod971))))))))) (build-lexical-assignment218 (lambda (source972 name973 var974 exp975) (let ((atom-key976 (fluid-ref *mode*205))) (if (memv atom-key976 (quote (c))) ((@ (language tree-il) make-lexical-set) source972 name973 var974 exp975) (list (quote set!) var974 exp975))))) (build-lexical-reference217 (lambda (type977 source978 name979 var980) (let ((atom-key981 (fluid-ref *mode*205))) (if (memv atom-key981 (quote (c))) ((@ (language tree-il) make-lexical-ref) source978 name979 var980) var980)))) (build-conditional216 (lambda (source982 test-exp983 then-exp984 else-exp985) (let ((atom-key986 (fluid-ref *mode*205))) (if (memv atom-key986 (quote (c))) ((@ (language tree-il) make-conditional) source982 test-exp983 then-exp984 else-exp985) (if (equal? else-exp985 (quote (if #f #f))) (list (quote if) test-exp983 then-exp984) (list (quote if) test-exp983 then-exp984 else-exp985)))))) (build-application215 (lambda (source987 fun-exp988 arg-exps989) (let ((atom-key990 (fluid-ref *mode*205))) (if (memv atom-key990 (quote (c))) ((@ (language tree-il) make-application) source987 fun-exp988 arg-exps989) (cons fun-exp988 arg-exps989))))) (build-void214 (lambda (source991) (let ((atom-key992 (fluid-ref *mode*205))) (if (memv atom-key992 (quote (c))) ((@ (language tree-il) make-void) source991) (quote (if #f #f)))))) (get-global-definition-hook213 (lambda (symbol993 module994) (begin (if (if (not module994) (current-module) #f) (warn "module system is booted, we should have a module" symbol993)) (let ((v995 (module-variable (if module994 (resolve-module (cdr module994)) (current-module)) symbol993))) (if v995 (if (variable-bound? v995) (let ((val996 (variable-ref v995))) (if (macro? val996) (if (syncase-macro-type val996) (cons (syncase-macro-type val996) (syncase-macro-binding val996)) #f) #f)) #f) #f))))) (put-global-definition-hook212 (lambda (symbol997 type998 val999) (let ((existing1000 (let ((v1001 (module-variable (current-module) symbol997))) (if v1001 (if (variable-bound? v1001) (let ((val1002 (variable-ref v1001))) (if (macro? val1002) (if (not (syncase-macro-type val1002)) val1002 #f) #f)) #f) #f)))) (module-define! (current-module) symbol997 (if existing1000 (make-extended-syncase-macro existing1000 type998 val999) (make-syncase-macro type998 val999)))))) (local-eval-hook211 (lambda (x1003 mod1004) (primitive-eval (list noexpand204 (let ((atom-key1005 (fluid-ref *mode*205))) (if (memv atom-key1005 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1003) x1003)))))) (top-level-eval-hook210 (lambda (x1006 mod1007) (primitive-eval (list noexpand204 (let ((atom-key1008 (fluid-ref *mode*205))) (if (memv atom-key1008 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1006) x1006)))))) (fx<209 <) (fx=208 =) (fx-207 -) (fx+206 +) (*mode*205 (make-fluid)) (noexpand204 "noexpand")) (begin (global-extend246 (quote local-syntax) (quote letrec-syntax) #t) (global-extend246 (quote local-syntax) (quote let-syntax) #f) (global-extend246 (quote core) (quote fluid-let-syntax) (lambda (e1009 r1010 w1011 s1012 mod1013) ((lambda (tmp1014) ((lambda (tmp1015) (if (if tmp1015 (apply (lambda (_1016 var1017 val1018 e11019 e21020) (valid-bound-ids?273 var1017)) tmp1015) #f) (apply (lambda (_1022 var1023 val1024 e11025 e21026) (let ((names1027 (map (lambda (x1028) (id-var-name270 x1028 w1011)) var1023))) (begin (for-each (lambda (id1030 n1031) (let ((atom-key1032 (binding-type240 (lookup245 n1031 r1010 mod1013)))) (if (memv atom-key1032 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1009 (source-wrap277 id1030 w1011 s1012 mod1013))))) var1023 names1027) (chi-body288 (cons e11025 e21026) (source-wrap277 e1009 w1011 s1012 mod1013) (extend-env242 names1027 (let ((trans-r1035 (macros-only-env244 r1010))) (map (lambda (x1036) (cons (quote macro) (eval-local-transformer291 (chi284 x1036 trans-r1035 w1011 mod1013) mod1013))) val1024)) r1010) w1011 mod1013)))) tmp1015) ((lambda (_1038) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap277 e1009 w1011 s1012 mod1013))) tmp1014))) ($sc-dispatch tmp1014 (quote (any #(each (any any)) any . each-any))))) e1009))) (global-extend246 (quote core) (quote quote) (lambda (e1039 r1040 w1041 s1042 mod1043) ((lambda (tmp1044) ((lambda (tmp1045) (if tmp1045 (apply (lambda (_1046 e1047) (build-data226 s1042 (strip294 e1047 w1041))) tmp1045) ((lambda (_1048) (syntax-violation (quote quote) "bad syntax" (source-wrap277 e1039 w1041 s1042 mod1043))) tmp1044))) ($sc-dispatch tmp1044 (quote (any any))))) e1039))) (global-extend246 (quote core) (quote syntax) (letrec ((regen1056 (lambda (x1057) (let ((atom-key1058 (car x1057))) (if (memv atom-key1058 (quote (ref))) (build-lexical-reference217 (quote value) #f (cadr x1057) (cadr x1057)) (if (memv atom-key1058 (quote (primitive))) (build-primref225 #f (cadr x1057)) (if (memv atom-key1058 (quote (quote))) (build-data226 #f (cadr x1057)) (if (memv atom-key1058 (quote (lambda))) (build-lambda224 #f (cadr x1057) (cadr x1057) #f (regen1056 (caddr x1057))) (build-application215 #f (build-primref225 #f (car x1057)) (map regen1056 (cdr x1057)))))))))) (gen-vector1055 (lambda (x1059) (if (eq? (car x1059) (quote list)) (cons (quote vector) (cdr x1059)) (if (eq? (car x1059) (quote quote)) (list (quote quote) (list->vector (cadr x1059))) (list (quote list->vector) x1059))))) (gen-append1054 (lambda (x1060 y1061) (if (equal? y1061 (quote (quote ()))) x1060 (list (quote append) x1060 y1061)))) (gen-cons1053 (lambda (x1062 y1063) (let ((atom-key1064 (car y1063))) (if (memv atom-key1064 (quote (quote))) (if (eq? (car x1062) (quote quote)) (list (quote quote) (cons (cadr x1062) (cadr y1063))) (if (eq? (cadr y1063) (quote ())) (list (quote list) x1062) (list (quote cons) x1062 y1063))) (if (memv atom-key1064 (quote (list))) (cons (quote list) (cons x1062 (cdr y1063))) (list (quote cons) x1062 y1063)))))) (gen-map1052 (lambda (e1065 map-env1066) (let ((formals1067 (map cdr map-env1066)) (actuals1068 (map (lambda (x1069) (list (quote ref) (car x1069))) map-env1066))) (if (eq? (car e1065) (quote ref)) (car actuals1068) (if (and-map (lambda (x1070) (if (eq? (car x1070) (quote ref)) (memq (cadr x1070) formals1067) #f)) (cdr e1065)) (cons (quote map) (cons (list (quote primitive) (car e1065)) (map (let ((r1071 (map cons formals1067 actuals1068))) (lambda (x1072) (cdr (assq (cadr x1072) r1071)))) (cdr e1065)))) (cons (quote map) (cons (list (quote lambda) formals1067 e1065) actuals1068))))))) (gen-mappend1051 (lambda (e1073 map-env1074) (list (quote apply) (quote (primitive append)) (gen-map1052 e1073 map-env1074)))) (gen-ref1050 (lambda (src1075 var1076 level1077 maps1078) (if (fx=208 level1077 0) (values var1076 maps1078) (if (null? maps1078) (syntax-violation (quote syntax) "missing ellipsis" src1075) (call-with-values (lambda () (gen-ref1050 src1075 var1076 (fx-207 level1077 1) (cdr maps1078))) (lambda (outer-var1079 outer-maps1080) (let ((b1081 (assq outer-var1079 (car maps1078)))) (if b1081 (values (cdr b1081) maps1078) (let ((inner-var1082 (gen-var295 (quote tmp)))) (values inner-var1082 (cons (cons (cons outer-var1079 inner-var1082) (car maps1078)) outer-maps1080))))))))))) (gen-syntax1049 (lambda (src1083 e1084 r1085 maps1086 ellipsis?1087 mod1088) (if (id?248 e1084) (let ((label1089 (id-var-name270 e1084 (quote (()))))) (let ((b1090 (lookup245 label1089 r1085 mod1088))) (if (eq? (binding-type240 b1090) (quote syntax)) (call-with-values (lambda () (let ((var.lev1091 (binding-value241 b1090))) (gen-ref1050 src1083 (car var.lev1091) (cdr var.lev1091) maps1086))) (lambda (var1092 maps1093) (values (list (quote ref) var1092) maps1093))) (if (ellipsis?1087 e1084) (syntax-violation (quote syntax) "misplaced ellipsis" src1083) (values (list (quote quote) e1084) maps1086))))) ((lambda (tmp1094) ((lambda (tmp1095) (if (if tmp1095 (apply (lambda (dots1096 e1097) (ellipsis?1087 dots1096)) tmp1095) #f) (apply (lambda (dots1098 e1099) (gen-syntax1049 src1083 e1099 r1085 maps1086 (lambda (x1100) #f) mod1088)) tmp1095) ((lambda (tmp1101) (if (if tmp1101 (apply (lambda (x1102 dots1103 y1104) (ellipsis?1087 dots1103)) tmp1101) #f) (apply (lambda (x1105 dots1106 y1107) (letrec ((f1108 (lambda (y1109 k1110) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (dots1116 y1117) (ellipsis?1087 dots1116)) tmp1115) #f) (apply (lambda (dots1118 y1119) (f1108 y1119 (lambda (maps1120) (call-with-values (lambda () (k1110 (cons (quote ()) maps1120))) (lambda (x1121 maps1122) (if (null? (car maps1122)) (syntax-violation (quote syntax) "extra ellipsis" src1083) (values (gen-mappend1051 x1121 (car maps1122)) (cdr maps1122)))))))) tmp1115) ((lambda (_1123) (call-with-values (lambda () (gen-syntax1049 src1083 y1109 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (y1124 maps1125) (call-with-values (lambda () (k1110 maps1125)) (lambda (x1126 maps1127) (values (gen-append1054 x1126 y1124) maps1127)))))) tmp1114))) ($sc-dispatch tmp1114 (quote (any . any))))) y1109)))) (f1108 y1107 (lambda (maps1111) (call-with-values (lambda () (gen-syntax1049 src1083 x1105 r1085 (cons (quote ()) maps1111) ellipsis?1087 mod1088)) (lambda (x1112 maps1113) (if (null? (car maps1113)) (syntax-violation (quote syntax) "extra ellipsis" src1083) (values (gen-map1052 x1112 (car maps1113)) (cdr maps1113))))))))) tmp1101) ((lambda (tmp1128) (if tmp1128 (apply (lambda (x1129 y1130) (call-with-values (lambda () (gen-syntax1049 src1083 x1129 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (x1131 maps1132) (call-with-values (lambda () (gen-syntax1049 src1083 y1130 r1085 maps1132 ellipsis?1087 mod1088)) (lambda (y1133 maps1134) (values (gen-cons1053 x1131 y1133) maps1134)))))) tmp1128) ((lambda (tmp1135) (if tmp1135 (apply (lambda (e11136 e21137) (call-with-values (lambda () (gen-syntax1049 src1083 (cons e11136 e21137) r1085 maps1086 ellipsis?1087 mod1088)) (lambda (e1139 maps1140) (values (gen-vector1055 e1139) maps1140)))) tmp1135) ((lambda (_1141) (values (list (quote quote) e1084) maps1086)) tmp1094))) ($sc-dispatch tmp1094 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1094 (quote (any . any)))))) ($sc-dispatch tmp1094 (quote (any any . any)))))) ($sc-dispatch tmp1094 (quote (any any))))) e1084))))) (lambda (e1142 r1143 w1144 s1145 mod1146) (let ((e1147 (source-wrap277 e1142 w1144 s1145 mod1146))) ((lambda (tmp1148) ((lambda (tmp1149) (if tmp1149 (apply (lambda (_1150 x1151) (call-with-values (lambda () (gen-syntax1049 e1147 x1151 r1143 (quote ()) ellipsis?293 mod1146)) (lambda (e1152 maps1153) (regen1056 e1152)))) tmp1149) ((lambda (_1154) (syntax-violation (quote syntax) "bad `syntax' form" e1147)) tmp1148))) ($sc-dispatch tmp1148 (quote (any any))))) e1147))))) (global-extend246 (quote core) (quote lambda) (lambda (e1155 r1156 w1157 s1158 mod1159) ((lambda (tmp1160) ((lambda (tmp1161) (if tmp1161 (apply (lambda (_1162 c1163) (chi-lambda-clause289 (source-wrap277 e1155 w1157 s1158 mod1159) #f c1163 r1156 w1157 mod1159 (lambda (names1164 vars1165 docstring1166 body1167) (build-lambda224 s1158 names1164 vars1165 docstring1166 body1167)))) tmp1161) (syntax-violation #f "source expression failed to match any pattern" tmp1160))) ($sc-dispatch tmp1160 (quote (any . any))))) e1155))) (global-extend246 (quote core) (quote let) (letrec ((chi-let1168 (lambda (e1169 r1170 w1171 s1172 mod1173 constructor1174 ids1175 vals1176 exps1177) (if (not (valid-bound-ids?273 ids1175)) (syntax-violation (quote let) "duplicate bound variable" e1169) (let ((labels1178 (gen-labels254 ids1175)) (new-vars1179 (map gen-var295 ids1175))) (let ((nw1180 (make-binding-wrap265 ids1175 labels1178 w1171)) (nr1181 (extend-var-env243 labels1178 new-vars1179 r1170))) (constructor1174 s1172 (map syntax->datum ids1175) new-vars1179 (map (lambda (x1182) (chi284 x1182 r1170 w1171 mod1173)) vals1176) (chi-body288 exps1177 (source-wrap277 e1169 nw1180 s1172 mod1173) nr1181 nw1180 mod1173)))))))) (lambda (e1183 r1184 w1185 s1186 mod1187) ((lambda (tmp1188) ((lambda (tmp1189) (if (if tmp1189 (apply (lambda (_1190 id1191 val1192 e11193 e21194) (and-map id?248 id1191)) tmp1189) #f) (apply (lambda (_1196 id1197 val1198 e11199 e21200) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-let228 id1197 val1198 (cons e11199 e21200))) tmp1189) ((lambda (tmp1204) (if (if tmp1204 (apply (lambda (_1205 f1206 id1207 val1208 e11209 e21210) (if (id?248 f1206) (and-map id?248 id1207) #f)) tmp1204) #f) (apply (lambda (_1212 f1213 id1214 val1215 e11216 e21217) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-named-let229 (cons f1213 id1214) val1215 (cons e11216 e21217))) tmp1204) ((lambda (_1221) (syntax-violation (quote let) "bad let" (source-wrap277 e1183 w1185 s1186 mod1187))) tmp1188))) ($sc-dispatch tmp1188 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1188 (quote (any #(each (any any)) any . each-any))))) e1183)))) (global-extend246 (quote core) (quote letrec) (lambda (e1222 r1223 w1224 s1225 mod1226) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (_1229 id1230 val1231 e11232 e21233) (and-map id?248 id1230)) tmp1228) #f) (apply (lambda (_1235 id1236 val1237 e11238 e21239) (let ((ids1240 id1236)) (if (not (valid-bound-ids?273 ids1240)) (syntax-violation (quote letrec) "duplicate bound variable" e1222) (let ((labels1242 (gen-labels254 ids1240)) (new-vars1243 (map gen-var295 ids1240))) (let ((w1244 (make-binding-wrap265 ids1240 labels1242 w1224)) (r1245 (extend-var-env243 labels1242 new-vars1243 r1223))) (build-letrec230 s1225 (map syntax->datum ids1240) new-vars1243 (map (lambda (x1246) (chi284 x1246 r1245 w1244 mod1226)) val1237) (chi-body288 (cons e11238 e21239) (source-wrap277 e1222 w1244 s1225 mod1226) r1245 w1244 mod1226))))))) tmp1228) ((lambda (_1249) (syntax-violation (quote letrec) "bad letrec" (source-wrap277 e1222 w1224 s1225 mod1226))) tmp1227))) ($sc-dispatch tmp1227 (quote (any #(each (any any)) any . each-any))))) e1222))) (global-extend246 (quote core) (quote set!) (lambda (e1250 r1251 w1252 s1253 mod1254) ((lambda (tmp1255) ((lambda (tmp1256) (if (if tmp1256 (apply (lambda (_1257 id1258 val1259) (id?248 id1258)) tmp1256) #f) (apply (lambda (_1260 id1261 val1262) (let ((val1263 (chi284 val1262 r1251 w1252 mod1254)) (n1264 (id-var-name270 id1261 w1252))) (let ((b1265 (lookup245 n1264 r1251 mod1254))) (let ((atom-key1266 (binding-type240 b1265))) (if (memv atom-key1266 (quote (lexical))) (build-lexical-assignment218 s1253 (syntax->datum id1261) (binding-value241 b1265) val1263) (if (memv atom-key1266 (quote (global))) (build-global-assignment221 s1253 n1264 val1263 mod1254) (if (memv atom-key1266 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap276 id1261 w1252 mod1254)) (syntax-violation (quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254))))))))) tmp1256) ((lambda (tmp1267) (if tmp1267 (apply (lambda (_1268 head1269 tail1270 val1271) (call-with-values (lambda () (syntax-type282 head1269 r1251 (quote (())) #f #f mod1254)) (lambda (type1272 value1273 ee1274 ww1275 ss1276 modmod1277) (if (memv type1272 (quote (module-ref))) (let ((val1278 (chi284 val1271 r1251 w1252 mod1254))) (call-with-values (lambda () (value1273 (cons head1269 tail1270))) (lambda (id1280 mod1281) (build-global-assignment221 s1253 id1280 val1278 mod1281)))) (build-application215 s1253 (chi284 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1269) r1251 w1252 mod1254) (map (lambda (e1282) (chi284 e1282 r1251 w1252 mod1254)) (append tail1270 (list val1271)))))))) tmp1267) ((lambda (_1284) (syntax-violation (quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254))) tmp1255))) ($sc-dispatch tmp1255 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1255 (quote (any any any))))) e1250))) (global-extend246 (quote module-ref) (quote @) (lambda (e1285) ((lambda (tmp1286) ((lambda (tmp1287) (if (if tmp1287 (apply (lambda (_1288 mod1289 id1290) (if (and-map id?248 mod1289) (id?248 id1290) #f)) tmp1287) #f) (apply (lambda (_1292 mod1293 id1294) (values (syntax->datum id1294) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1293)))) tmp1287) (syntax-violation #f "source expression failed to match any pattern" tmp1286))) ($sc-dispatch tmp1286 (quote (any each-any any))))) e1285))) (global-extend246 (quote module-ref) (quote @@) (lambda (e1296) ((lambda (tmp1297) ((lambda (tmp1298) (if (if tmp1298 (apply (lambda (_1299 mod1300 id1301) (if (and-map id?248 mod1300) (id?248 id1301) #f)) tmp1298) #f) (apply (lambda (_1303 mod1304 id1305) (values (syntax->datum id1305) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1304)))) tmp1298) (syntax-violation #f "source expression failed to match any pattern" tmp1297))) ($sc-dispatch tmp1297 (quote (any each-any any))))) e1296))) (global-extend246 (quote core) (quote if) (lambda (e1307 r1308 w1309 s1310 mod1311) ((lambda (tmp1312) ((lambda (tmp1313) (if tmp1313 (apply (lambda (_1314 test1315 then1316) (build-conditional216 s1310 (chi284 test1315 r1308 w1309 mod1311) (chi284 then1316 r1308 w1309 mod1311) (build-void214 #f))) tmp1313) ((lambda (tmp1317) (if tmp1317 (apply (lambda (_1318 test1319 then1320 else1321) (build-conditional216 s1310 (chi284 test1319 r1308 w1309 mod1311) (chi284 then1320 r1308 w1309 mod1311) (chi284 else1321 r1308 w1309 mod1311))) tmp1317) (syntax-violation #f "source expression failed to match any pattern" tmp1312))) ($sc-dispatch tmp1312 (quote (any any any any)))))) ($sc-dispatch tmp1312 (quote (any any any))))) e1307))) (global-extend246 (quote begin) (quote begin) (quote ())) (global-extend246 (quote define) (quote define) (quote ())) (global-extend246 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend246 (quote eval-when) (quote eval-when) (quote ())) (global-extend246 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1325 (lambda (x1326 keys1327 clauses1328 r1329 mod1330) (if (null? clauses1328) (build-application215 #f (build-primref225 #f (quote syntax-violation)) (list (build-data226 #f #f) (build-data226 #f "source expression failed to match any pattern") x1326)) ((lambda (tmp1331) ((lambda (tmp1332) (if tmp1332 (apply (lambda (pat1333 exp1334) (if (if (id?248 pat1333) (and-map (lambda (x1335) (not (free-id=?271 pat1333 x1335))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1327)) #f) (let ((labels1336 (list (gen-label253))) (var1337 (gen-var295 pat1333))) (build-application215 #f (build-lambda224 #f (list (syntax->datum pat1333)) (list var1337) #f (chi284 exp1334 (extend-env242 labels1336 (list (cons (quote syntax) (cons var1337 0))) r1329) (make-binding-wrap265 (list pat1333) labels1336 (quote (()))) mod1330)) (list x1326))) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1333 #t exp1334 mod1330))) tmp1332) ((lambda (tmp1338) (if tmp1338 (apply (lambda (pat1339 fender1340 exp1341) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1339 fender1340 exp1341 mod1330)) tmp1338) ((lambda (_1342) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1328))) tmp1331))) ($sc-dispatch tmp1331 (quote (any any any)))))) ($sc-dispatch tmp1331 (quote (any any))))) (car clauses1328))))) (gen-clause1324 (lambda (x1343 keys1344 clauses1345 r1346 pat1347 fender1348 exp1349 mod1350) (call-with-values (lambda () (convert-pattern1322 pat1347 keys1344)) (lambda (p1351 pvars1352) (if (not (distinct-bound-ids?274 (map car pvars1352))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1347) (if (not (and-map (lambda (x1353) (not (ellipsis?293 (car x1353)))) pvars1352)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1347) (let ((y1354 (gen-var295 (quote tmp)))) (build-application215 #f (build-lambda224 #f (list (quote tmp)) (list y1354) #f (let ((y1355 (build-lexical-reference217 (quote value) #f (quote tmp) y1354))) (build-conditional216 #f ((lambda (tmp1356) ((lambda (tmp1357) (if tmp1357 (apply (lambda () y1355) tmp1357) ((lambda (_1358) (build-conditional216 #f y1355 (build-dispatch-call1323 pvars1352 fender1348 y1355 r1346 mod1350) (build-data226 #f #f))) tmp1356))) ($sc-dispatch tmp1356 (quote #(atom #t))))) fender1348) (build-dispatch-call1323 pvars1352 exp1349 y1355 r1346 mod1350) (gen-syntax-case1325 x1343 keys1344 clauses1345 r1346 mod1350)))) (list (if (eq? p1351 (quote any)) (build-application215 #f (build-primref225 #f (quote list)) (list x1343)) (build-application215 #f (build-primref225 #f (quote $sc-dispatch)) (list x1343 (build-data226 #f p1351))))))))))))) (build-dispatch-call1323 (lambda (pvars1359 exp1360 y1361 r1362 mod1363) (let ((ids1364 (map car pvars1359)) (levels1365 (map cdr pvars1359))) (let ((labels1366 (gen-labels254 ids1364)) (new-vars1367 (map gen-var295 ids1364))) (build-application215 #f (build-primref225 #f (quote apply)) (list (build-lambda224 #f (map syntax->datum ids1364) new-vars1367 #f (chi284 exp1360 (extend-env242 labels1366 (map (lambda (var1368 level1369) (cons (quote syntax) (cons var1368 level1369))) new-vars1367 (map cdr pvars1359)) r1362) (make-binding-wrap265 ids1364 labels1366 (quote (()))) mod1363)) y1361)))))) (convert-pattern1322 (lambda (pattern1370 keys1371) (letrec ((cvt1372 (lambda (p1373 n1374 ids1375) (if (id?248 p1373) (if (bound-id-member?275 p1373 keys1371) (values (vector (quote free-id) p1373) ids1375) (values (quote any) (cons (cons p1373 n1374) ids1375))) ((lambda (tmp1376) ((lambda (tmp1377) (if (if tmp1377 (apply (lambda (x1378 dots1379) (ellipsis?293 dots1379)) tmp1377) #f) (apply (lambda (x1380 dots1381) (call-with-values (lambda () (cvt1372 x1380 (fx+206 n1374 1) ids1375)) (lambda (p1382 ids1383) (values (if (eq? p1382 (quote any)) (quote each-any) (vector (quote each) p1382)) ids1383)))) tmp1377) ((lambda (tmp1384) (if tmp1384 (apply (lambda (x1385 y1386) (call-with-values (lambda () (cvt1372 y1386 n1374 ids1375)) (lambda (y1387 ids1388) (call-with-values (lambda () (cvt1372 x1385 n1374 ids1388)) (lambda (x1389 ids1390) (values (cons x1389 y1387) ids1390)))))) tmp1384) ((lambda (tmp1391) (if tmp1391 (apply (lambda () (values (quote ()) ids1375)) tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (x1393) (call-with-values (lambda () (cvt1372 x1393 n1374 ids1375)) (lambda (p1395 ids1396) (values (vector (quote vector) p1395) ids1396)))) tmp1392) ((lambda (x1397) (values (vector (quote atom) (strip294 p1373 (quote (())))) ids1375)) tmp1376))) ($sc-dispatch tmp1376 (quote #(vector each-any)))))) ($sc-dispatch tmp1376 (quote ()))))) ($sc-dispatch tmp1376 (quote (any . any)))))) ($sc-dispatch tmp1376 (quote (any any))))) p1373))))) (cvt1372 pattern1370 0 (quote ())))))) (lambda (e1398 r1399 w1400 s1401 mod1402) (let ((e1403 (source-wrap277 e1398 w1400 s1401 mod1402))) ((lambda (tmp1404) ((lambda (tmp1405) (if tmp1405 (apply (lambda (_1406 val1407 key1408 m1409) (if (and-map (lambda (x1410) (if (id?248 x1410) (not (ellipsis?293 x1410)) #f)) key1408) (let ((x1412 (gen-var295 (quote tmp)))) (build-application215 s1401 (build-lambda224 #f (list (quote tmp)) (list x1412) #f (gen-syntax-case1325 (build-lexical-reference217 (quote value) #f (quote tmp) x1412) key1408 m1409 r1399 mod1402)) (list (chi284 val1407 r1399 (quote (())) mod1402)))) (syntax-violation (quote syntax-case) "invalid literals list" e1403))) tmp1405) (syntax-violation #f "source expression failed to match any pattern" tmp1404))) ($sc-dispatch tmp1404 (quote (any any each-any . each-any))))) e1403))))) (set! sc-expand (lambda (x1416 . rest1415) (if (if (pair? x1416) (equal? (car x1416) noexpand204) #f) (cadr x1416) (let ((m1417 (if (null? rest1415) (quote e) (car rest1415))) (esew1418 (if (let ((t1419 (null? rest1415))) (if t1419 t1419 (null? (cdr rest1415)))) (quote (eval)) (cadr rest1415)))) (with-fluid* *mode*205 m1417 (lambda () (chi-top283 x1416 (quote ()) (quote ((top))) m1417 esew1418 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1420) (nonsymbol-id?247 x1420))) (set! datum->syntax (lambda (id1421 datum1422) (make-syntax-object231 datum1422 (syntax-object-wrap234 id1421) #f))) (set! syntax->datum (lambda (x1423) (strip294 x1423 (quote (()))))) (set! generate-temporaries (lambda (ls1424) (begin (let ((x1425 ls1424)) (if (not (list? x1425)) (syntax-violation (quote generate-temporaries) "invalid argument" x1425))) (map (lambda (x1426) (wrap276 (gensym) (quote ((top))) #f)) ls1424)))) (set! free-identifier=? (lambda (x1427 y1428) (begin (let ((x1429 x1427)) (if (not (nonsymbol-id?247 x1429)) (syntax-violation (quote free-identifier=?) "invalid argument" x1429))) (let ((x1430 y1428)) (if (not (nonsymbol-id?247 x1430)) (syntax-violation (quote free-identifier=?) "invalid argument" x1430))) (free-id=?271 x1427 y1428)))) (set! bound-identifier=? (lambda (x1431 y1432) (begin (let ((x1433 x1431)) (if (not (nonsymbol-id?247 x1433)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1433))) (let ((x1434 y1432)) (if (not (nonsymbol-id?247 x1434)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1434))) (bound-id=?272 x1431 y1432)))) (set! syntax-violation (lambda (who1438 message1437 form1436 . subform1435) (begin (let ((x1439 who1438)) (if (not ((lambda (x1440) (let ((t1441 (not x1440))) (if t1441 t1441 (let ((t1442 (string? x1440))) (if t1442 t1442 (symbol? x1440)))))) x1439)) (syntax-violation (quote syntax-violation) "invalid argument" x1439))) (let ((x1443 message1437)) (if (not (string? x1443)) (syntax-violation (quote syntax-violation) "invalid argument" x1443))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1438 "~a: " "") "~a " (if (null? subform1435) "in ~a" "in subform `~s' of `~s'")) (let ((tail1444 (cons message1437 (map (lambda (x1445) (strip294 x1445 (quote (())))) (append subform1435 (list form1436)))))) (if who1438 (cons who1438 tail1444) tail1444)) #f)))) (letrec ((match1450 (lambda (e1451 p1452 w1453 r1454 mod1455) (if (not r1454) #f (if (eq? p1452 (quote any)) (cons (wrap276 e1451 w1453 mod1455) r1454) (if (syntax-object?232 e1451) (match*1449 (syntax-object-expression233 e1451) p1452 (join-wraps267 w1453 (syntax-object-wrap234 e1451)) r1454 (syntax-object-module235 e1451)) (match*1449 e1451 p1452 w1453 r1454 mod1455)))))) (match*1449 (lambda (e1456 p1457 w1458 r1459 mod1460) (if (null? p1457) (if (null? e1456) r1459 #f) (if (pair? p1457) (if (pair? e1456) (match1450 (car e1456) (car p1457) w1458 (match1450 (cdr e1456) (cdr p1457) w1458 r1459 mod1460) mod1460) #f) (if (eq? p1457 (quote each-any)) (let ((l1461 (match-each-any1447 e1456 w1458 mod1460))) (if l1461 (cons l1461 r1459) #f)) (let ((atom-key1462 (vector-ref p1457 0))) (if (memv atom-key1462 (quote (each))) (if (null? e1456) (match-empty1448 (vector-ref p1457 1) r1459) (let ((l1463 (match-each1446 e1456 (vector-ref p1457 1) w1458 mod1460))) (if l1463 (letrec ((collect1464 (lambda (l1465) (if (null? (car l1465)) r1459 (cons (map car l1465) (collect1464 (map cdr l1465))))))) (collect1464 l1463)) #f))) (if (memv atom-key1462 (quote (free-id))) (if (id?248 e1456) (if (free-id=?271 (wrap276 e1456 w1458 mod1460) (vector-ref p1457 1)) r1459 #f) #f) (if (memv atom-key1462 (quote (atom))) (if (equal? (vector-ref p1457 1) (strip294 e1456 w1458)) r1459 #f) (if (memv atom-key1462 (quote (vector))) (if (vector? e1456) (match1450 (vector->list e1456) (vector-ref p1457 1) w1458 r1459 mod1460) #f))))))))))) (match-empty1448 (lambda (p1466 r1467) (if (null? p1466) r1467 (if (eq? p1466 (quote any)) (cons (quote ()) r1467) (if (pair? p1466) (match-empty1448 (car p1466) (match-empty1448 (cdr p1466) r1467)) (if (eq? p1466 (quote each-any)) (cons (quote ()) r1467) (let ((atom-key1468 (vector-ref p1466 0))) (if (memv atom-key1468 (quote (each))) (match-empty1448 (vector-ref p1466 1) r1467) (if (memv atom-key1468 (quote (free-id atom))) r1467 (if (memv atom-key1468 (quote (vector))) (match-empty1448 (vector-ref p1466 1) r1467))))))))))) (match-each-any1447 (lambda (e1469 w1470 mod1471) (if (pair? e1469) (let ((l1472 (match-each-any1447 (cdr e1469) w1470 mod1471))) (if l1472 (cons (wrap276 (car e1469) w1470 mod1471) l1472) #f)) (if (null? e1469) (quote ()) (if (syntax-object?232 e1469) (match-each-any1447 (syntax-object-expression233 e1469) (join-wraps267 w1470 (syntax-object-wrap234 e1469)) mod1471) #f))))) (match-each1446 (lambda (e1473 p1474 w1475 mod1476) (if (pair? e1473) (let ((first1477 (match1450 (car e1473) p1474 w1475 (quote ()) mod1476))) (if first1477 (let ((rest1478 (match-each1446 (cdr e1473) p1474 w1475 mod1476))) (if rest1478 (cons first1477 rest1478) #f)) #f)) (if (null? e1473) (quote ()) (if (syntax-object?232 e1473) (match-each1446 (syntax-object-expression233 e1473) p1474 (join-wraps267 w1475 (syntax-object-wrap234 e1473)) (syntax-object-module235 e1473)) #f)))))) (set! $sc-dispatch (lambda (e1479 p1480) (if (eq? p1480 (quote any)) (list e1479) (if (syntax-object?232 e1479) (match*1449 (syntax-object-expression233 e1479) p1480 (syntax-object-wrap234 e1479) (quote ()) (syntax-object-module235 e1479)) (match*1449 e1479 p1480 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1481) ((lambda (tmp1482) ((lambda (tmp1483) (if tmp1483 (apply (lambda (_1484 e11485 e21486) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11485 e21486))) tmp1483) ((lambda (tmp1488) (if tmp1488 (apply (lambda (_1489 out1490 in1491 e11492 e21493) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1491 (quote ()) (list out1490 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11492 e21493))))) tmp1488) ((lambda (tmp1495) (if tmp1495 (apply (lambda (_1496 out1497 in1498 e11499 e21500) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1498) (quote ()) (list out1497 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11499 e21500))))) tmp1495) (syntax-violation #f "source expression failed to match any pattern" tmp1482))) ($sc-dispatch tmp1482 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any () any . each-any))))) x1481)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 k1508 keyword1509 pattern1510 template1511) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1508 (map (lambda (tmp1514 tmp1513) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1513) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1514))) template1511 pattern1510)))))) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any each-any . #(each ((any . any) any))))))) x1504)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if (if tmp1517 (apply (lambda (let*1518 x1519 v1520 e11521 e21522) (and-map identifier? x1519)) tmp1517) #f) (apply (lambda (let*1524 x1525 v1526 e11527 e21528) (letrec ((f1529 (lambda (bindings1530) (if (null? bindings1530) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11527 e21528))) ((lambda (tmp1534) ((lambda (tmp1535) (if tmp1535 (apply (lambda (body1536 binding1537) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1537) body1536)) tmp1535) (syntax-violation #f "source expression failed to match any pattern" tmp1534))) ($sc-dispatch tmp1534 (quote (any any))))) (list (f1529 (cdr bindings1530)) (car bindings1530))))))) (f1529 (map list x1525 v1526)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any #(each (any any)) any . each-any))))) x1515)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1538) ((lambda (tmp1539) ((lambda (tmp1540) (if tmp1540 (apply (lambda (_1541 var1542 init1543 step1544 e01545 e11546 c1547) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (step1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1552) ((lambda (tmp1557) (if tmp1557 (apply (lambda (e11558 e21559) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11558 e21559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1557) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any . each-any)))))) ($sc-dispatch tmp1551 (quote ())))) e11546)) tmp1549) (syntax-violation #f "source expression failed to match any pattern" tmp1548))) ($sc-dispatch tmp1548 (quote each-any)))) (map (lambda (v1566 s1567) ((lambda (tmp1568) ((lambda (tmp1569) (if tmp1569 (apply (lambda () v1566) tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda (e1571) e1571) tmp1570) ((lambda (_1572) (syntax-violation (quote do) "bad step expression" orig-x1538 s1567)) tmp1568))) ($sc-dispatch tmp1568 (quote (any)))))) ($sc-dispatch tmp1568 (quote ())))) s1567)) var1542 step1544))) tmp1540) (syntax-violation #f "source expression failed to match any pattern" tmp1539))) ($sc-dispatch tmp1539 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1538)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1575 (lambda (x1579 y1580) ((lambda (tmp1581) ((lambda (tmp1582) (if tmp1582 (apply (lambda (x1583 y1584) ((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (dy1587) ((lambda (tmp1588) ((lambda (tmp1589) (if tmp1589 (apply (lambda (dx1590) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1590 dy1587))) tmp1589) ((lambda (_1591) (if (null? dy1587) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584))) tmp1588))) ($sc-dispatch tmp1588 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1583)) tmp1586) ((lambda (tmp1592) (if tmp1592 (apply (lambda (stuff1593) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1583 stuff1593))) tmp1592) ((lambda (else1594) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584)) tmp1585))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1584)) tmp1582) (syntax-violation #f "source expression failed to match any pattern" tmp1581))) ($sc-dispatch tmp1581 (quote (any any))))) (list x1579 y1580)))) (quasiappend1576 (lambda (x1595 y1596) ((lambda (tmp1597) ((lambda (tmp1598) (if tmp1598 (apply (lambda (x1599 y1600) ((lambda (tmp1601) ((lambda (tmp1602) (if tmp1602 (apply (lambda () x1599) tmp1602) ((lambda (_1603) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1599 y1600)) tmp1601))) ($sc-dispatch tmp1601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1600)) tmp1598) (syntax-violation #f "source expression failed to match any pattern" tmp1597))) ($sc-dispatch tmp1597 (quote (any any))))) (list x1595 y1596)))) (quasivector1577 (lambda (x1604) ((lambda (tmp1605) ((lambda (x1606) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (x1609) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1609))) tmp1608) ((lambda (tmp1611) (if tmp1611 (apply (lambda (x1612) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1612)) tmp1611) ((lambda (_1614) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1606)) tmp1607))) ($sc-dispatch tmp1607 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1606)) tmp1605)) x1604))) (quasi1578 (lambda (p1615 lev1616) ((lambda (tmp1617) ((lambda (tmp1618) (if tmp1618 (apply (lambda (p1619) (if (= lev1616 0) p1619 (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1619) (- lev1616 1))))) tmp1618) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (args1621) (= lev1616 0)) tmp1620) #f) (apply (lambda (args1622) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1615 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1622))) tmp1620) ((lambda (tmp1623) (if tmp1623 (apply (lambda (p1624 q1625) (if (= lev1616 0) (quasiappend1576 p1624 (quasi1578 q1625 lev1616)) (quasicons1575 (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1624) (- lev1616 1))) (quasi1578 q1625 lev1616)))) tmp1623) ((lambda (tmp1626) (if (if tmp1626 (apply (lambda (args1627 q1628) (= lev1616 0)) tmp1626) #f) (apply (lambda (args1629 q1630) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1615 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1629))) tmp1626) ((lambda (tmp1631) (if tmp1631 (apply (lambda (p1632) (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1632) (+ lev1616 1)))) tmp1631) ((lambda (tmp1633) (if tmp1633 (apply (lambda (p1634 q1635) (quasicons1575 (quasi1578 p1634 lev1616) (quasi1578 q1635 lev1616))) tmp1633) ((lambda (tmp1636) (if tmp1636 (apply (lambda (x1637) (quasivector1577 (quasi1578 x1637 lev1616))) tmp1636) ((lambda (p1639) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1639)) tmp1617))) ($sc-dispatch tmp1617 (quote #(vector each-any)))))) ($sc-dispatch tmp1617 (quote (any . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1615)))) (lambda (x1640) ((lambda (tmp1641) ((lambda (tmp1642) (if tmp1642 (apply (lambda (_1643 e1644) (quasi1578 e1644 0)) tmp1642) (syntax-violation #f "source expression failed to match any pattern" tmp1641))) ($sc-dispatch tmp1641 (quote (any any))))) x1640))))) +(define include (make-syncase-macro (quote macro) (lambda (x1645) (letrec ((read-file1646 (lambda (fn1647 k1648) (let ((p1649 (open-input-file fn1647))) (letrec ((f1650 (lambda (x1651) (if (eof-object? x1651) (begin (close-input-port p1649) (quote ())) (cons (datum->syntax k1648 x1651) (f1650 (read p1649))))))) (f1650 (read p1649))))))) ((lambda (tmp1652) ((lambda (tmp1653) (if tmp1653 (apply (lambda (k1654 filename1655) (let ((fn1656 (syntax->datum filename1655))) ((lambda (tmp1657) ((lambda (tmp1658) (if tmp1658 (apply (lambda (exp1659) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1659)) tmp1658) (syntax-violation #f "source expression failed to match any pattern" tmp1657))) ($sc-dispatch tmp1657 (quote each-any)))) (read-file1646 fn1656 k1654)))) tmp1653) (syntax-violation #f "source expression failed to match any pattern" tmp1652))) ($sc-dispatch tmp1652 (quote (any any))))) x1645))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1661) ((lambda (tmp1662) ((lambda (tmp1663) (if tmp1663 (apply (lambda (_1664 e1665) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1661)) tmp1663) (syntax-violation #f "source expression failed to match any pattern" tmp1662))) ($sc-dispatch tmp1662 (quote (any any))))) x1661)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1666) ((lambda (tmp1667) ((lambda (tmp1668) (if tmp1668 (apply (lambda (_1669 e1670) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1666)) tmp1668) (syntax-violation #f "source expression failed to match any pattern" tmp1667))) ($sc-dispatch tmp1667 (quote (any any))))) x1666)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1671) ((lambda (tmp1672) ((lambda (tmp1673) (if tmp1673 (apply (lambda (_1674 e1675 m11676 m21677) ((lambda (tmp1678) ((lambda (body1679) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1675)) body1679)) tmp1678)) (letrec ((f1680 (lambda (clause1681 clauses1682) (if (null? clauses1682) ((lambda (tmp1684) ((lambda (tmp1685) (if tmp1685 (apply (lambda (e11686 e21687) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11686 e21687))) tmp1685) ((lambda (tmp1689) (if tmp1689 (apply (lambda (k1690 e11691 e21692) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1690)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11691 e21692)))) tmp1689) ((lambda (_1695) (syntax-violation (quote case) "bad clause" x1671 clause1681)) tmp1684))) ($sc-dispatch tmp1684 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1684 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1681) ((lambda (tmp1696) ((lambda (rest1697) ((lambda (tmp1698) ((lambda (tmp1699) (if tmp1699 (apply (lambda (k1700 e11701 e21702) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1700)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11701 e21702)) rest1697)) tmp1699) ((lambda (_1705) (syntax-violation (quote case) "bad clause" x1671 clause1681)) tmp1698))) ($sc-dispatch tmp1698 (quote (each-any any . each-any))))) clause1681)) tmp1696)) (f1680 (car clauses1682) (cdr clauses1682))))))) (f1680 m11676 m21677)))) tmp1673) (syntax-violation #f "source expression failed to match any pattern" tmp1672))) ($sc-dispatch tmp1672 (quote (any any any . each-any))))) x1671)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1706) ((lambda (tmp1707) ((lambda (tmp1708) (if tmp1708 (apply (lambda (_1709 e1710) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1710)) (list (cons _1709 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1710 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1708) (syntax-violation #f "source expression failed to match any pattern" tmp1707))) ($sc-dispatch tmp1707 (quote (any any))))) x1706)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index cd2c53224..c2668c0c4 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -22,6 +22,9 @@ ;;; Extracted from Chez Scheme Version 5.9f ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman +;;; Modified by Andy Wingo according to the Git +;;; revision control logs corresponding to this file: 2009. + ;;; Modified by Mikael Djurfeldt according ;;; to the ChangeLog distributed in the same directory as this file: ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24, @@ -49,7 +52,7 @@ ;;; also documented in the R4RS and draft R5RS. ;;; ;;; bound-identifier=? -;;; datum->syntax-object +;;; datum->syntax ;;; define-syntax ;;; fluid-let-syntax ;;; free-identifier=? @@ -60,7 +63,7 @@ ;;; letrec-syntax ;;; syntax ;;; syntax-case -;;; syntax-object->datum +;;; syntax->datum ;;; syntax-rules ;;; with-syntax ;;; @@ -79,46 +82,14 @@ ;;; conditionally evaluates expr ... at compile-time or run-time ;;; depending upon situations (see the Chez Scheme System Manual, ;;; Revision 3, for a complete description) -;;; (syntax-error object message) +;;; (syntax-violation who message form [subform]) ;;; used to report errors found during expansion -;;; (install-global-transformer symbol value) -;;; used by expanded code to install top-level syntactic abstractions -;;; (syntax-dispatch e p) +;;; ($sc-dispatch e p) ;;; used by expanded code to handle syntax-case matching ;;; The following nonstandard procedures must be provided by the -;;; implementation for this code to run. -;;; -;;; (void) -;;; returns the implementation's cannonical "unspecified value". This -;;; usually works: (define void (lambda () (if #f #f))). -;;; -;;; (andmap proc list1 list2 ...) -;;; returns true if proc returns true when applied to each element of list1 -;;; along with the corresponding elements of list2 .... -;;; The following definition works but does no error checking: -;;; -;;; (define andmap -;;; (lambda (f first . rest) -;;; (or (null? first) -;;; (if (null? rest) -;;; (let andmap ((first first)) -;;; (let ((x (car first)) (first (cdr first))) -;;; (if (null? first) -;;; (f x) -;;; (and (f x) (andmap first))))) -;;; (let andmap ((first first) (rest rest)) -;;; (let ((x (car first)) -;;; (xr (map car rest)) -;;; (first (cdr first)) -;;; (rest (map cdr rest))) -;;; (if (null? first) -;;; (apply f (cons x xr)) -;;; (and (apply f (cons x xr)) (andmap first rest))))))))) -;;; -;;; The following nonstandard procedures must also be provided by the ;;; implementation for this code to run using the standard portable -;;; hooks and output constructors. They are not used by expanded code, +;;; hooks and output constructors. They are not used by expanded code, ;;; and so need be present only at expansion time. ;;; ;;; (eval x) @@ -134,21 +105,8 @@ ;;; by eval, and eval accepts one argument, nothing special must be done ;;; to support the "noexpand" flag, since it is handled by sc-expand. ;;; -;;; (error who format-string why what) -;;; where who is either a symbol or #f, format-string is always "~a ~s", -;;; why is always a string, and what may be any object. error should -;;; signal an error with a message something like -;;; -;;; "error in : " -;;; ;;; (gensym) ;;; returns a unique symbol each time it's called -;;; -;;; (putprop symbol key value) -;;; (getprop symbol key) -;;; key is always the symbol *sc-expander*; value may be any object. -;;; putprop should associate the given value with the given symbol in -;;; some way that it can be retrieved later with getprop. ;;; When porting to a new Scheme implementation, you should define the ;;; procedures listed above, load the expanded version of psyntax.ss @@ -209,7 +167,7 @@ ;;; Objects with no standard print syntax, including objects containing ;;; cycles and syntax object, are allowed in quoted data as long as they -;;; are contained within a syntax form or produced by datum->syntax-object. +;;; are contained within a syntax form or produced by datum->syntax. ;;; Such objects are never copied. ;;; All identifiers that don't have macro definitions and are not bound @@ -233,19 +191,6 @@ ;;; The implementation of generate-temporaries assumes that it is possible ;;; to generate globally unique symbols (gensyms). -;;; The input to sc-expand may contain "annotations" describing, e.g., the -;;; source file and character position from where each object was read if -;;; it was read from a file. These annotations are handled properly by -;;; sc-expand only if the annotation? hook (see hooks below) is implemented -;;; properly and the operators make-annotation, annotation-expression, -;;; annotation-source, annotation-stripped, and set-annotation-stripped! -;;; are supplied. If annotations are supplied, the proper annotation -;;; source is passed to the various output constructors, allowing -;;; implementations to accurately correlate source and expanded code. -;;; Contact one of the authors for details if you wish to make use of -;;; this feature. - - ;;; Bootstrapping: @@ -256,23 +201,45 @@ +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (let () +;;; Private version of and-map that handles multiple lists. +(define and-map* + (lambda (f first . rest) + (or (null? first) + (if (null? rest) + (let andmap ((first first)) + (let ((x (car first)) (first (cdr first))) + (if (null? first) + (f x) + (and (f x) (andmap first))))) + (let andmap ((first first) (rest rest)) + (let ((x (car first)) + (xr (map car rest)) + (first (cdr first)) + (rest (map cdr rest))) + (if (null? first) + (apply f (cons x xr)) + (and (apply f (cons x xr)) (andmap first rest))))))))) + (define-syntax define-structure (lambda (x) (define construct-name (lambda (template-identifier . args) - (datum->syntax-object + (datum->syntax template-identifier (string->symbol (apply string-append (map (lambda (x) (if (string? x) x - (symbol->string (syntax-object->datum x)))) + (symbol->string (syntax->datum x)))) args)))))) (syntax-case x () ((_ (name id1 ...)) - (andmap identifier? (syntax (name id1 ...))) + (and-map identifier? (syntax (name id1 ...))) (with-syntax ((constructor (construct-name (syntax name) "make-" (syntax name))) (predicate (construct-name (syntax name) (syntax name) "?")) @@ -310,6 +277,7 @@ (let () (define noexpand "noexpand") +(define *mode* (make-fluid)) ;;; hooks to nonportable run-time helpers (begin @@ -320,170 +288,255 @@ (define top-level-eval-hook (lambda (x mod) - (eval `(,noexpand ,x) (if mod (resolve-module mod) - (interaction-environment))))) + (primitive-eval + `(,noexpand + ,(case (fluid-ref *mode*) + ((c) ((@ (language tree-il) tree-il->scheme) x)) + (else x)))))) (define local-eval-hook (lambda (x mod) - (eval `(,noexpand ,x) (if mod (resolve-module mod) - (interaction-environment))))) - -(define error-hook - (lambda (who why what) - (error who "~a ~s" why what))) + (primitive-eval + `(,noexpand + ,(case (fluid-ref *mode*) + ((c) ((@ (language tree-il) tree-il->scheme) x)) + (else x)))))) (define-syntax gensym-hook (syntax-rules () ((_) (gensym)))) (define put-global-definition-hook - (lambda (symbol binding module) - (let* ((module (if module - (resolve-module module) - (warn "wha" symbol (current-module)))) - (v (or (module-variable module symbol) - (let ((v (make-variable sc-macro))) - (module-add! module symbol v) - v)))) - ;; Don't destroy Guile macros corresponding to primitive syntax - ;; when syncase boots. - (if (not (and (symbol-property symbol 'primitive-syntax) - (eq? module the-syncase-module))) - (variable-set! v sc-macro)) - ;; Properties are tied to variable objects - (set-object-property! v '*sc-expander* binding)))) + (lambda (symbol type val) + (let ((existing (let ((v (module-variable (current-module) symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) + (not (syncase-macro-type val)) + val)))))) + (module-define! (current-module) + symbol + (if existing + (make-extended-syncase-macro existing type val) + (make-syncase-macro type val)))))) (define get-global-definition-hook (lambda (symbol module) - (let* ((module (if module - (resolve-module module) - (warn "wha" symbol (current-module)))) - (v (module-variable module symbol))) - (and v - (or (object-property v '*sc-expander*) - (and (variable-bound? v) - (macro? (variable-ref v)) - (macro-transformer (variable-ref v)) ;non-primitive - guile-macro)))))) + (if (and (not module) (current-module)) + (warn "module system is booted, we should have a module" symbol)) + (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) (syncase-macro-type val) + (cons (syncase-macro-type val) + (syncase-macro-binding val)))))))) + ) ;;; output constructors -(define (build-annotated src exp) - (if (and src (not (annotation? exp))) - (make-annotation exp src #t) - exp)) +(define build-void + (lambda (source) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-void) source)) + (else '(if #f #f))))) -(define-syntax build-application - (syntax-rules () - ((_ source fun-exp arg-exps) - (build-annotated source `(,fun-exp . ,arg-exps))))) +(define build-application + (lambda (source fun-exp arg-exps) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps)) + (else `(,fun-exp . ,arg-exps))))) -(define-syntax build-conditional - (syntax-rules () - ((_ source test-exp then-exp else-exp) - (build-annotated source `(if ,test-exp ,then-exp ,else-exp))))) +(define build-conditional + (lambda (source test-exp then-exp else-exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-conditional) + source test-exp then-exp else-exp)) + (else (if (equal? else-exp '(if #f #f)) + `(if ,test-exp ,then-exp) + `(if ,test-exp ,then-exp ,else-exp)))))) -(define-syntax build-lexical-reference - (syntax-rules () - ((_ type source var) - (build-annotated source var)))) +(define build-lexical-reference + (lambda (type source name var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lexical-ref) source name var)) + (else var)))) -(define-syntax build-lexical-assignment - (syntax-rules () - ((_ source var exp) - (build-annotated source `(set! ,var ,exp))))) +(define build-lexical-assignment + (lambda (source name var exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lexical-set) source name var exp)) + (else `(set! ,var ,exp))))) -(define-syntax build-global-reference - (syntax-rules () - ((_ source var mod) - (build-annotated source - (make-module-ref mod var #f))))) +;; Before modules are booted, we can't expand into data structures from +;; (language tree-il) -- we need to give the evaluator the +;; s-expressions that it understands natively. Actually the real truth +;; of the matter is that the evaluator doesn't understand tree-il +;; structures at all. So until we fix the evaluator, if ever, the +;; conflation that we should use tree-il iff we are compiling +;; holds true. +;; +(define (analyze-variable mod var modref-cont bare-cont) + (if (not mod) + (bare-cont var) + (let ((kind (car mod)) + (mod (cdr mod))) + (case kind + ((public) (modref-cont mod var #t)) + ((private) (if (not (equal? mod (module-name (current-module)))) + (modref-cont mod var #f) + (bare-cont var))) + ((bare) (bare-cont var)) + ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) + (module-variable (resolve-module mod) var)) + (modref-cont mod var #f) + (bare-cont var))) + (else (syntax-violation #f "bad module kind" var mod)))))) -(define-syntax build-global-assignment - (syntax-rules () - ((_ source var exp mod) - (build-annotated source - `(set! ,(make-module-ref mod var #f) ,exp))))) +(define build-global-reference + (lambda (source var mod) + (analyze-variable + mod var + (lambda (mod var public?) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) source mod var public?)) + (else (list (if public? '@ '@@) mod var)))) + (lambda (var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) source var)) + (else var)))))) -(define-syntax build-global-definition - (syntax-rules () - ((_ source var exp mod) - (build-annotated source `(define ,var ,exp))))) +(define build-global-assignment + (lambda (source var exp mod) + (analyze-variable + mod var + (lambda (mod var public?) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-set) source mod var public? exp)) + (else `(set! ,(list (if public? '@ '@@) mod var) ,exp)))) + (lambda (var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-set) source var exp)) + (else `(set! ,var ,exp))))))) -(define-syntax build-lambda - (syntax-rules () - ((_ src vars exp) - (build-annotated src `(lambda ,vars ,exp))))) +;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz) +;; from working. Hack around it. +(define (maybe-name-value! name val) + (cond + (((@ (language tree-il) lambda?) val) + (let ((meta ((@ (language tree-il) lambda-meta) val))) + (if (not (assq 'name meta)) + ((setter (@ (language tree-il) lambda-meta)) + val + (acons 'name name meta))))))) -;; FIXME: wingo: add modules here somehow? -(define-syntax build-primref - (syntax-rules () - ((_ src name) (build-annotated src name)) - ((_ src level name) (build-annotated src name)))) +(define build-global-definition + (lambda (source var exp) + (case (fluid-ref *mode*) + ((c) + (maybe-name-value! var exp) + ((@ (language tree-il) make-toplevel-define) source var exp)) + (else `(define ,var ,exp))))) + +(define build-lambda + (lambda (src ids vars docstring exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lambda) src ids vars + (if docstring `((documentation . ,docstring)) '()) + exp)) + (else `(lambda ,vars ,@(if docstring (list docstring) '()) + ,exp))))) + +(define build-primref + (lambda (src name) + (if (equal? (module-name (current-module)) '(guile)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) src name)) + (else name)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f)) + (else `(@@ (guile) ,name)))))) (define (build-data src exp) - (if (and (self-evaluating? exp) - (not (vector? exp))) - (build-annotated src exp) - (build-annotated src (list 'quote exp)))) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-const) src exp)) + (else (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))))) (define build-sequence (lambda (src exps) (if (null? (cdr exps)) - (build-annotated src (car exps)) - (build-annotated src `(begin ,@exps))))) + (car exps) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-sequence) src exps)) + (else `(begin ,@exps)))))) (define build-let - (lambda (src vars val-exps body-exp) + (lambda (src ids vars val-exps body-exp) (if (null? vars) - (build-annotated src body-exp) - (build-annotated src `(let ,(map list vars val-exps) ,body-exp))))) + body-exp + (case (fluid-ref *mode*) + ((c) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-let) src ids vars val-exps body-exp)) + (else `(let ,(map list vars val-exps) ,body-exp)))))) (define build-named-let - (lambda (src vars val-exps body-exp) - (if (null? vars) - (build-annotated src body-exp) - (build-annotated src - `(let ,(car vars) - ,(map list (cdr vars) val-exps) ,body-exp))))) + (lambda (src ids vars val-exps body-exp) + (let ((f (car vars)) + (f-name (car ids)) + (vars (cdr vars)) + (ids (cdr ids))) + (case (fluid-ref *mode*) + ((c) + (let ((proc (build-lambda src ids vars #f body-exp))) + (maybe-name-value! f-name proc) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-letrec) src + (list f-name) (list f) (list proc) + (build-application src (build-lexical-reference 'fun src f-name f) + val-exps)))) + (else `(let ,f ,(map list vars val-exps) ,body-exp)))))) (define build-letrec - (lambda (src vars val-exps body-exp) + (lambda (src ids vars val-exps body-exp) (if (null? vars) - (build-annotated src body-exp) - (build-annotated src - `(letrec ,(map list vars val-exps) ,body-exp))))) + body-exp + (case (fluid-ref *mode*) + ((c) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp)) + (else `(letrec ,(map list vars val-exps) ,body-exp)))))) -;; FIXME: wingo: use make-lexical +;; FIXME: wingo: use make-lexical ? (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (build-annotated src (gensym (symbol->string id)))))) + ((_ src id) (gensym (symbol->string id))))) (define-structure (syntax-object expression wrap module)) -(define-syntax unannotate - (syntax-rules () - ((_ x) - (let ((e x)) - (if (annotation? e) - (annotation-expression e) - e))))) - (define-syntax no-source (identifier-syntax #f)) (define source-annotation (lambda (x) (cond - ((annotation? x) (annotation-source x)) - ((syntax-object? x) (source-annotation (syntax-object-expression x))) - (else no-source)))) + ((syntax-object? x) + (source-annotation (syntax-object-expression x))) + ((pair? x) (let ((props (source-properties x))) + (if (pair? props) + props + #f))) + (else #f)))) (define-syntax arg-check (syntax-rules () ((_ pred? e who) (let ((x e)) - (if (not (pred? x)) (error-hook who "invalid argument" x)))))) + (if (not (pred? x)) (syntax-violation who "invalid argument" x)))))) ;;; compile-time environments @@ -593,8 +646,7 @@ (define global-extend (lambda (type sym val) - (put-global-definition-hook sym (make-binding type val) - (module-name (current-module))))) + (put-global-definition-hook sym type val))) ;;; Conceptually, identifiers are always syntax objects. Internally, @@ -605,29 +657,30 @@ (define nonsymbol-id? (lambda (x) (and (syntax-object? x) - (symbol? (unannotate (syntax-object-expression x)))))) + (symbol? (syntax-object-expression x))))) (define id? (lambda (x) (cond ((symbol? x) #t) - ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x)))) - ((annotation? x) (symbol? (annotation-expression x))) + ((syntax-object? x) (symbol? (syntax-object-expression x))) (else #f)))) (define-syntax id-sym-name (syntax-rules () ((_ e) (let ((x e)) - (unannotate (if (syntax-object? x) (syntax-object-expression x) x)))))) + (if (syntax-object? x) + (syntax-object-expression x) + x))))) (define id-sym-name&marks (lambda (x w) (if (syntax-object? x) (values - (unannotate (syntax-object-expression x)) - (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) - (values (unannotate x) (wrap-marks w))))) + (syntax-object-expression x) + (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) + (values x (wrap-marks w))))) ;;; syntax object wraps @@ -693,7 +746,7 @@ ; must receive ids with complete wraps (lambda (ribcage id label) (set-ribcage-symnames! ribcage - (cons (unannotate (syntax-object-expression id)) + (cons (syntax-object-expression id) (ribcage-symnames ribcage))) (set-ribcage-marks! ribcage (cons (wrap-marks (syntax-object-wrap id)) @@ -793,7 +846,7 @@ ((symbol? id) (or (first (search id (wrap-subst w) (wrap-marks w))) id)) ((syntax-object? id) - (let ((id (unannotate (syntax-object-expression id))) + (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) (call-with-values (lambda () (search id (wrap-subst w) marks)) @@ -801,10 +854,7 @@ (or new-id (first (search id (wrap-subst w1) marks)) id)))))) - ((annotation? id) - (let ((id (unannotate id))) - (or (first (search id (wrap-subst w) (wrap-marks w))) id))) - (else (error-hook 'id-var-name "invalid id" id))))) + (else (syntax-violation 'id-var-name "invalid id" id))))) ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y) ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. @@ -821,11 +871,11 @@ (define bound-id=? (lambda (i j) (if (and (syntax-object? i) (syntax-object? j)) - (and (eq? (unannotate (syntax-object-expression i)) - (unannotate (syntax-object-expression j))) + (and (eq? (syntax-object-expression i) + (syntax-object-expression j)) (same-marks? (wrap-marks (syntax-object-wrap i)) (wrap-marks (syntax-object-wrap j)))) - (eq? (unannotate i) (unannotate j))))) + (eq? i j)))) ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids. ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids @@ -875,7 +925,9 @@ (define source-wrap (lambda (x w s defmod) - (wrap (if s (make-annotation x s #f) x) w defmod))) + (if (and s (pair? x)) + (set-source-properties! x s)) + (wrap x w defmod))) ;;; expanding @@ -897,12 +949,33 @@ (let ((first (chi-top (car body) r w m esew mod))) (cons first (dobody (cdr body) r w m esew mod)))))))) -;; FIXME: module? (define chi-install-global (lambda (name e) - (build-application no-source - (build-primref no-source 'install-global-transformer) - (list (build-data no-source name) e)))) + (build-global-definition + no-source + name + ;; FIXME: seems nasty to call current-module here + (if (let ((v (module-variable (current-module) name))) + ;; FIXME use primitive-macro? + (and v (variable-bound? v) (macro? (variable-ref v)) + (not (eq? (macro-type (variable-ref v)) 'syncase-macro)))) + (build-application + no-source + (build-primref no-source 'make-extended-syncase-macro) + (list (build-application + no-source + (build-primref no-source 'module-ref) + (list (build-application + no-source + (build-primref no-source 'current-module) + '()) + (build-data no-source name))) + (build-data no-source 'macro) + e)) + (build-application + no-source + (build-primref no-source 'make-syncase-macro) + (list (build-data no-source 'macro) e)))))) (define chi-when-list (lambda (e when-list w) @@ -916,8 +989,9 @@ ((free-id=? x (syntax compile)) 'compile) ((free-id=? x (syntax load)) 'load) ((free-id=? x (syntax eval)) 'eval) - (else (syntax-error (wrap x w #f) - "invalid eval-when situation")))) + (else (syntax-violation 'eval-when + "invalid situation" + e (wrap x w #f))))) situations)))))) ;;; syntax-type returns six values: type, value, e, w, s, and mod. The @@ -1009,7 +1083,7 @@ ((_ name) (id? (syntax name)) (values 'define-form (wrap (syntax name) w mod) - (syntax (void)) + (syntax (if #f #f)) empty-wrap s mod)))) ((define-syntax) (syntax-case e () @@ -1021,13 +1095,10 @@ (values 'call #f e w s mod)))) (values 'call #f e w s mod)))) ((syntax-object? e) - ;; s can't be valid source if we've unwrapped (syntax-type (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e)) - no-source rib (or (syntax-object-module e) mod))) - ((annotation? e) - (syntax-type (annotation-expression e) r w (annotation-source e) rib mod)) + s rib (or (syntax-object-module e) mod))) ((self-evaluating? e) (values 'constant #f e w s mod)) (else (values 'other #f e w s mod))))) @@ -1040,7 +1111,7 @@ (if (eq? m 'c&e) (top-level-eval-hook x mod)) x)))) (call-with-values - (lambda () (syntax-type e r w no-source #f mod)) + (lambda () (syntax-type e r w (source-annotation e) #f mod)) (lambda (type value e w s mod) (case type ((begin-form) @@ -1101,25 +1172,22 @@ (let* ((n (id-var-name value w)) (type (binding-type (lookup n r mod)))) (case type - ((global) + ((global core macro module-ref) (eval-if-c&e m - (build-global-definition s n (chi e r w mod) mod) + (build-global-definition s n (chi e r w mod)) mod)) ((displaced-lexical) - (syntax-error (wrap value w mod) "identifier out of context")) + (syntax-violation #f "identifier out of context" + e (wrap value w mod))) (else - (if (eq? type 'external-macro) - (eval-if-c&e m - (build-global-definition s n (chi e r w mod) mod) - mod) - (syntax-error (wrap value w mod) - "cannot define keyword at top level")))))) + (syntax-violation #f "cannot define keyword at top level" + e (wrap value w mod)))))) (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) (define chi (lambda (e r w mod) (call-with-values - (lambda () (syntax-type e r w no-source #f mod)) + (lambda () (syntax-type e r w (source-annotation e) #f mod)) (lambda (type value e w s mod) (chi-expr type value e r w s mod))))) @@ -1127,7 +1195,7 @@ (lambda (type value e r w s mod) (case type ((lexical) - (build-lexical-reference 'value s value)) + (build-lexical-reference 'value s e value)) ((core external-macro) ;; apply transformer (value e r w s mod)) @@ -1137,7 +1205,8 @@ (lambda (id mod) (build-global-reference s id mod)))) ((lexical-call) (chi-application - (build-lexical-reference 'fun (source-annotation (car e)) value) + (build-lexical-reference 'fun (source-annotation (car e)) + (car e) value) e r w s mod)) ((global-call) (chi-application @@ -1162,14 +1231,16 @@ (chi-sequence (syntax (e1 e2 ...)) r w s mod) (chi-void)))))) ((define-form define-syntax-form) - (syntax-error (wrap value w mod) "invalid context for definition of")) + (syntax-violation #f "definition in expression context" + e (wrap value w mod))) ((syntax) - (syntax-error (source-wrap e w s mod) - "reference to pattern variable outside syntax form")) + (syntax-violation #f "reference to pattern variable outside syntax form" + (source-wrap e w s mod))) ((displaced-lexical) - (syntax-error (source-wrap e w s mod) - "reference to identifier outside its scope")) - (else (syntax-error (source-wrap e w s mod)))))) + (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)))))) (define chi-application (lambda (x e r w s mod) @@ -1201,7 +1272,14 @@ (if rib (cons rib (cons 'shift s)) (cons 'shift s))) - (module-name (procedure-module p))))))) ;; hither the hygiene + (let ((pmod (procedure-module p))) + (if pmod + ;; hither the hygiene + (cons 'hygiene (module-name pmod)) + ;; but it's possible for the proc to have + ;; no mod, if it was made before modules + ;; were booted + '(hygiene guile)))))))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) @@ -1209,7 +1287,8 @@ (vector-set! v i (rebuild-macro-output (vector-ref x i) m))))) ((symbol? x) - (syntax-error x "encountered raw symbol in macro output")) + (syntax-violation #f "encountered raw symbol in macro output" + (source-wrap e w s mod) x)) (else x)))) (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark)))) @@ -1257,12 +1336,13 @@ (ribcage (make-empty-ribcage)) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) - (ids '()) (labels '()) (vars '()) (vals '()) (bindings '())) + (ids '()) (labels '()) + (var-ids '()) (vars '()) (vals '()) (bindings '())) (if (null? body) - (syntax-error outer-form "no expressions in 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 empty-wrap no-source ribcage mod)) + (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod)) (lambda (type value e w s mod) (case type ((define-form) @@ -1271,6 +1351,7 @@ (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 (make-binding 'lexical var) bindings))))) ((define-syntax-form) @@ -1278,7 +1359,7 @@ (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) - vars vals + var-ids vars vals (cons (make-binding 'macro (cons er (wrap e w mod))) bindings)))) ((begin-form) @@ -1289,7 +1370,7 @@ (cdr body) (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids labels vars vals bindings)))) + ids labels var-ids vars vals bindings)))) ((local-syntax-form) (chi-local-syntax value e er w s mod (lambda (forms er w s mod) @@ -1298,7 +1379,7 @@ (cdr body) (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids labels vars vals bindings)))) + ids labels var-ids vars vals bindings)))) (else ; found a non-definition (if (null? ids) (build-sequence no-source @@ -1308,8 +1389,9 @@ (cdr body)))) (begin (if (not (valid-bound-ids? ids)) - (syntax-error outer-form - "invalid or duplicate identifier in definition")) + (syntax-violation + #f "invalid or duplicate identifier in definition" + outer-form)) (let loop ((bs bindings) (er-cache #f) (r-cache #f)) (if (not (null? bs)) (let* ((b (car bs))) @@ -1327,6 +1409,7 @@ (loop (cdr bs) er-cache r-cache))))) (set-cdr! r (extend-env labels bindings (cdr r))) (build-letrec no-source + (map syntax->datum var-ids) vars (map (lambda (x) (chi (cdr x) (car x) empty-wrap mod)) @@ -1338,15 +1421,20 @@ (cdr body))))))))))))))))) (define chi-lambda-clause - (lambda (e c r w mod k) + (lambda (e docstring c r w mod k) (syntax-case c () + ((args doc e1 e2 ...) + (and (string? (syntax->datum (syntax doc))) (not docstring)) + (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k)) (((id ...) e1 e2 ...) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "invalid parameter list in") + (syntax-violation 'lambda "invalid parameter list" e) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (k new-vars + (k (map syntax->datum ids) + new-vars + (and docstring (syntax->datum docstring)) (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) @@ -1355,19 +1443,24 @@ ((ids e1 e2 ...) (let ((old-ids (lambda-var-list (syntax ids)))) (if (not (valid-bound-ids? old-ids)) - (syntax-error e "invalid parameter list in") + (syntax-violation 'lambda "invalid parameter list" e) (let ((labels (gen-labels old-ids)) (new-vars (map gen-var old-ids))) - (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars))) + (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids))) + (if (null? ls1) + (syntax->datum ls2) + (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2)))) + (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars))) (if (null? ls1) ls2 (f (cdr ls1) (cons (car ls1) ls2)))) + (and docstring (syntax->datum docstring)) (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) (make-binding-wrap old-ids labels w) mod)))))) - (_ (syntax-error e))))) + (_ (syntax-violation 'lambda "bad lambda" e))))) (define chi-local-syntax (lambda (rec? e r w s mod k) @@ -1375,7 +1468,7 @@ ((_ ((id val) ...) e1 e2 ...) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound keyword in") + (syntax-violation #f "duplicate bound keyword" e) (let ((labels (gen-labels ids))) (let ((new-w (make-binding-wrap ids labels w))) (k (syntax (e1 e2 ...)) @@ -1393,18 +1486,19 @@ new-w s mod)))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation #f "bad local syntax definition" + (source-wrap e w s mod)))))) (define eval-local-transformer (lambda (expanded mod) (let ((p (local-eval-hook expanded mod))) (if (procedure? p) p - (syntax-error p "nonprocedure transformer"))))) + (syntax-violation #f "nonprocedure transformer" p))))) (define chi-void (lambda () - (build-application no-source (build-primref no-source 'void) '()))) + (build-void no-source))) (define ellipsis? (lambda (x) @@ -1413,32 +1507,8 @@ ;;; data -;;; strips all annotations from potentially circular reader output - -(define strip-annotation - (lambda (x parent) - (cond - ((pair? x) - (let ((new (cons #f #f))) - (if parent (set-annotation-stripped! parent new)) - (set-car! new (strip-annotation (car x) #f)) - (set-cdr! new (strip-annotation (cdr x) #f)) - new)) - ((annotation? x) - (or (annotation-stripped x) - (strip-annotation (annotation-expression x) x))) - ((vector? x) - (let ((new (make-vector (vector-length x)))) - (if parent (set-annotation-stripped! parent new)) - (let loop ((i (- (vector-length x) 1))) - (unless (fx< i 0) - (vector-set! new i (strip-annotation (vector-ref x i) #f)) - (loop (fx- i 1)))) - new)) - (else x)))) - -;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly -;;; on an annotation, strips the annotation as well. +;;; strips syntax-objects down to top-wrap +;;; ;;; since only the head of a list is annotated by the reader, not each pair ;;; in the spine, we also check for pairs whose cars are annotated in case ;;; we've been passed the cdr of an annotated list @@ -1446,32 +1516,28 @@ (define strip (lambda (x w) (if (top-marked? w) - (if (or (annotation? x) (and (pair? x) (annotation? (car x)))) - (strip-annotation x #f) - x) + 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))) - (let ((new (map f old))) - (if (andmap eq? old new) x (list->vector new))))) - (else x)))))) + ((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))) + (let ((new (map f old))) + (if (and-map* eq? old new) x (list->vector new))))) + (else x)))))) ;;; lexical variables (define gen-var (lambda (id) (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (if (annotation? id) - (build-lexical-var (annotation-source id) (annotation-expression id)) - (build-lexical-var no-source id))))) + (build-lexical-var no-source id)))) (define lambda-var-list (lambda (vars) @@ -1484,8 +1550,6 @@ (lvl (syntax-object-expression vars) ls (join-wraps w (syntax-object-wrap vars)))) - ((annotation? vars) - (lvl (annotation-expression vars) ls w)) ; include anything else to be caught by subsequent error ; checking (else (cons vars ls)))))) @@ -1505,8 +1569,10 @@ (lambda (id n) (case (binding-type (lookup n r mod)) ((displaced-lexical) - (syntax-error (source-wrap id w s mod) - "identifier out of context")))) + (syntax-violation 'fluid-let-syntax + "identifier out of context" + e + (source-wrap id w s mod))))) (syntax (var ...)) names) (chi-body @@ -1523,13 +1589,15 @@ r) w mod))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'fluid-let-syntax "bad syntax" + (source-wrap e w s mod)))))) (global-extend 'core 'quote (lambda (e r w s mod) (syntax-case e () ((_ e) (build-data s (strip (syntax e) w))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'quote "bad syntax" + (source-wrap e w s mod)))))) (global-extend 'core 'syntax (let () @@ -1545,7 +1613,7 @@ (gen-ref src (car var.lev) (cdr var.lev) maps))) (lambda (var maps) (values `(ref ,var) maps))) (if (ellipsis? e) - (syntax-error src "misplaced ellipsis in syntax form") + (syntax-violation 'syntax "misplaced ellipsis" src) (values `(quote ,e) maps))))) (syntax-case e () ((dots e) @@ -1563,8 +1631,8 @@ (cons '() maps) ellipsis? mod)) (lambda (x maps) (if (null? (car maps)) - (syntax-error src - "extra ellipsis in syntax form") + (syntax-violation 'syntax "extra ellipsis" + src) (values (gen-map x (car maps)) (cdr maps)))))))) (syntax-case y () @@ -1576,8 +1644,7 @@ (lambda () (k (cons '() maps))) (lambda (x maps) (if (null? (car maps)) - (syntax-error src - "extra ellipsis in syntax form") + (syntax-violation 'syntax "extra ellipsis" src) (values (gen-mappend x (car maps)) (cdr maps)))))))) (_ (call-with-values @@ -1606,7 +1673,7 @@ (if (fx= level 0) (values var maps) (if (null? maps) - (syntax-error src "missing ellipsis in syntax form") + (syntax-violation 'syntax "missing ellipsis" src) (call-with-values (lambda () (gen-ref src var (fx- level 1) (cdr maps))) (lambda (outer-var outer-maps) @@ -1632,7 +1699,7 @@ ; identity map equivalence: ; (map (lambda (x) x) y) == y (car actuals)) - ((andmap + ((and-map (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (cdr e)) ; eta map equivalence: @@ -1672,17 +1739,10 @@ (define regen (lambda (x) (case (car x) - ((ref) (build-lexical-reference 'value no-source (cadr x))) + ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) ((primitive) (build-primref no-source (cadr x))) ((quote) (build-data no-source (cadr x))) - ((lambda) (build-lambda no-source (cadr x) (regen (caddr x)))) - ((map) (let ((ls (map regen (cdr x)))) - (build-application no-source - (if (fx= (length ls) 2) - (build-primref no-source 'map) - ; really need to do our own checking here - (build-primref no-source 2 'map)) ; require error check - ls))) + ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x)))) (else (build-application no-source (build-primref no-source (car x)) (map regen (cdr x))))))) @@ -1694,27 +1754,29 @@ (call-with-values (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod)) (lambda (e maps) (regen e)))) - (_ (syntax-error e))))))) + (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) (global-extend 'core 'lambda (lambda (e r w s mod) (syntax-case e () ((_ . c) - (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod - (lambda (vars body) (build-lambda s vars body))))))) + (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod + (lambda (names vars docstring body) + (build-lambda s names vars docstring body))))))) (global-extend 'core 'let (let () (define (chi-let e r w s mod constructor ids vals exps) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound variable in") + (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) (chi x r w mod)) vals) (chi-body exps (source-wrap e nw s mod) @@ -1722,38 +1784,41 @@ (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) + (and-map id? (syntax (id ...))) (chi-let e r w s mod build-let (syntax (id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) ((_ f ((id val) ...) e1 e2 ...) - (id? (syntax f)) + (and (id? (syntax f)) (and-map id? (syntax (id ...)))) (chi-let e r w s mod build-named-let (syntax (f id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) - (_ (syntax-error (source-wrap e w s mod))))))) + (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) (global-extend 'core 'letrec (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) + (and-map id? (syntax (id ...))) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound variable in") + (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 + (map syntax->datum ids) new-vars (map (lambda (x) (chi x r w mod)) (syntax (val ...))) (chi-body (syntax (e1 e2 ...)) (source-wrap e w s mod) r w mod))))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) (global-extend 'core 'set! @@ -1766,45 +1831,66 @@ (let ((b (lookup n r mod))) (case (binding-type b) ((lexical) - (build-lexical-assignment s (binding-value b) val)) + (build-lexical-assignment s + (syntax->datum (syntax id)) + (binding-value b) + val)) ((global) (build-global-assignment s n val mod)) ((displaced-lexical) - (syntax-error (wrap (syntax id) w mod) - "identifier out of context")) - (else (syntax-error (source-wrap e w s mod))))))) + (syntax-violation 'set! "identifier out of context" + (wrap (syntax id) w mod))) + (else (syntax-violation 'set! "bad set!" + (source-wrap e w s mod))))))) ((_ (head tail ...) val) (call-with-values (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod)) (lambda (type value ee ww ss modmod) (case type ((module-ref) - (call-with-values (lambda () (value (syntax (head tail ...)))) - (lambda (id mod) - (build-global-assignment s id (syntax val) mod)))) + (let ((val (chi (syntax val) r w mod))) + (call-with-values (lambda () (value (syntax (head tail ...)))) + (lambda (id mod) + (build-global-assignment s id val mod))))) (else (build-application s (chi (syntax (setter head)) r w mod) (map (lambda (e) (chi e r w mod)) (syntax (tail ... val))))))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (global-extend 'module-ref '@ (lambda (e) - (syntax-case e (%module-public-interface) + (syntax-case e () ((_ (mod ...) id) - (and (andmap id? (syntax (mod ...))) (id? (syntax id))) - (values (syntax-object->datum (syntax id)) - (syntax-object->datum - (syntax (mod ... %module-public-interface)))))))) + (and (and-map id? (syntax (mod ...))) (id? (syntax id))) + (values (syntax->datum (syntax id)) + (syntax->datum + (syntax (public mod ...)))))))) (global-extend 'module-ref '@@ (lambda (e) (syntax-case e () ((_ (mod ...) id) - (and (andmap id? (syntax (mod ...))) (id? (syntax id))) - (values (syntax-object->datum (syntax id)) - (syntax-object->datum - (syntax (mod ...)))))))) + (and (and-map id? (syntax (mod ...))) (id? (syntax id))) + (values (syntax->datum (syntax id)) + (syntax->datum + (syntax (private mod ...)))))))) + +(global-extend 'core 'if + (lambda (e r w s mod) + (syntax-case e () + ((_ test then) + (build-conditional + s + (chi (syntax test) r w mod) + (chi (syntax then) r w mod) + (build-void no-source))) + ((_ test then else) + (build-conditional + s + (chi (syntax test) r w mod) + (chi (syntax then) r w mod) + (chi (syntax else) r w mod)))))) (global-extend 'begin 'begin '()) @@ -1818,7 +1904,7 @@ (let () (define convert-pattern ; accepts pattern & keys - ; returns syntax-dispatch pattern & ids + ; returns $sc-dispatch pattern & ids (lambda (pattern keys) (let cvt ((p pattern) (n 0) (ids '())) (if (id? p) @@ -1854,7 +1940,7 @@ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (build-application no-source (build-primref no-source 'apply) - (list (build-lambda no-source new-vars + (list (build-lambda no-source (map syntax->datum ids) new-vars #f (chi exp (extend-env labels @@ -1874,17 +1960,16 @@ (lambda (p pvars) (cond ((not (distinct-bound-ids? (map car pvars))) - (syntax-error pat - "duplicate pattern variable in syntax-case pattern")) - ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars)) - (syntax-error pat - "misplaced ellipsis in syntax-case pattern")) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) + ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars)) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) (else (let ((y (gen-var 'tmp))) ; fat finger binding and references to temp variable y (build-application no-source - (build-lambda no-source (list y) - (let ((y (build-lexical-reference 'value no-source y))) + (build-lambda no-source (list 'tmp) (list y) #f + (let ((y (build-lexical-reference 'value no-source + 'tmp y))) (build-conditional no-source (syntax-case fender () (#t y) @@ -1899,24 +1984,29 @@ (build-primref no-source 'list) (list x)) (build-application no-source - (build-primref no-source 'syntax-dispatch) + (build-primref no-source '$sc-dispatch) (list x (build-data no-source p))))))))))))) (define gen-syntax-case (lambda (x keys clauses r mod) (if (null? clauses) (build-application no-source - (build-primref no-source 'syntax-error) - (list x)) + (build-primref no-source 'syntax-violation) + (list (build-data no-source #f) + (build-data no-source + "source expression failed to match any pattern") + x)) (syntax-case (car clauses) () ((pat exp) (if (and (id? (syntax pat)) - (andmap (lambda (x) (not (free-id=? (syntax pat) x))) - (cons (syntax (... ...)) keys))) + (and-map (lambda (x) (not (free-id=? (syntax pat) x))) + (cons (syntax (... ...)) keys))) (let ((labels (list (gen-label))) (var (gen-var (syntax pat)))) (build-application no-source - (build-lambda no-source (list var) + (build-lambda no-source + (list (syntax->datum (syntax pat))) (list var) + #f (chi (syntax exp) (extend-env labels (list (make-binding 'syntax `(,var . 0))) @@ -1930,24 +2020,26 @@ ((pat fender exp) (gen-clause x keys (cdr clauses) r (syntax pat) (syntax fender) (syntax exp) mod)) - (_ (syntax-error (car clauses) "invalid syntax-case clause")))))) + (_ (syntax-violation 'syntax-case "invalid clause" + (car clauses))))))) (lambda (e r w s mod) (let ((e (source-wrap e w s mod))) (syntax-case e () ((_ val (key ...) m ...) - (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) - (syntax (key ...))) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) + (syntax (key ...))) (let ((x (gen-var 'tmp))) ; fat finger binding and references to temp variable x (build-application s - (build-lambda no-source (list x) - (gen-syntax-case (build-lexical-reference 'value no-source x) + (build-lambda no-source (list 'tmp) (list x) #f + (gen-syntax-case (build-lexical-reference 'value no-source + 'tmp x) (syntax (key ...)) (syntax (m ...)) r mod)) (list (chi (syntax val) r empty-wrap mod)))) - (syntax-error e "invalid literals list in")))))))) + (syntax-violation 'syntax-case "invalid literals list" e)))))))) ;;; The portable sc-expand seeds chi-top's mode m with 'e (for ;;; evaluating) and esew (which stands for "eval syntax expanders @@ -1959,36 +2051,27 @@ ;;; expanded, and the expanded definitions are also residualized into ;;; the object file if we are compiling a file. (set! sc-expand - (let ((m 'e) (esew '(eval))) - (lambda (x) - (if (and (pair? x) (equal? (car x) noexpand)) - (cadr x) - (chi-top x null-env top-wrap m esew - (module-name (current-module))))))) - -(set! sc-expand3 - (let ((m 'e) (esew '(eval))) - (lambda (x . rest) - (if (and (pair? x) (equal? (car x) noexpand)) - (cadr x) - (chi-top x - null-env - top-wrap - (if (null? rest) m (car rest)) - (if (or (null? rest) (null? (cdr rest))) - esew - (cadr rest)) - (module-name (current-module))))))) + (lambda (x . rest) + (if (and (pair? x) (equal? (car x) noexpand)) + (cadr x) + (let ((m (if (null? rest) 'e (car rest))) + (esew (if (or (null? rest) (null? (cdr rest))) + '(eval) + (cadr rest)))) + (with-fluid* *mode* m + (lambda () + (chi-top x null-env top-wrap m esew + (cons 'hygiene (module-name (current-module)))))))))) (set! identifier? (lambda (x) (nonsymbol-id? x))) -(set! datum->syntax-object +(set! datum->syntax (lambda (id datum) (make-syntax-object datum (syntax-object-wrap id) #f))) -(set! syntax-object->datum +(set! syntax->datum ; accepts any object, since syntax objects may consist partially ; or entirely of unwrapped, nonsymbolic data (lambda (x) @@ -2011,21 +2094,23 @@ (arg-check nonsymbol-id? y 'bound-identifier=?) (bound-id=? x y))) -(set! syntax-error - (lambda (object . messages) - (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages) - (let ((message (if (null? messages) - "invalid syntax" - (apply string-append messages)))) - (error-hook #f message (strip object empty-wrap))))) +(set! syntax-violation + (lambda (who message form . subform) + (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) + who 'syntax-violation) + (arg-check string? message 'syntax-violation) + (scm-error 'syntax-error 'sc-expand + (string-append + (if who "~a: " "") + "~a " + (if (null? subform) "in ~a" "in subform `~s' of `~s'")) + (let ((tail (cons message + (map (lambda (x) (strip x empty-wrap)) + (append subform (list form)))))) + (if who (cons who tail) tail)) + #f))) -(set! install-global-transformer - (lambda (sym v) - (arg-check symbol? sym 'define-syntax) - (arg-check procedure? v 'define-syntax) - (global-extend 'macro sym v))) - -;;; syntax-dispatch expects an expression and a pattern. If the expression +;;; $sc-dispatch expects an expression and a pattern. If the expression ;;; matches the pattern a list of the matching expressions for each ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will ;;; not work on r4rs implementations that violate the ieee requirement @@ -2052,35 +2137,31 @@ (define match-each (lambda (e p w mod) (cond - ((annotation? e) - (match-each (annotation-expression e) p w mod)) - ((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)))) + ((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)))) (define match-each-any (lambda (e w mod) (cond - ((annotation? e) - (match-each-any (annotation-expression e) w mod)) - ((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)))) + ((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)))) (define match-empty (lambda (p r) @@ -2129,23 +2210,22 @@ ((eq? p 'any) (cons (wrap e w mod) r)) ((syntax-object? e) (match* - (unannotate (syntax-object-expression e)) - p - (join-wraps w (syntax-object-wrap e)) - r - (syntax-object-module e))) - (else (match* (unannotate e) p w r mod))))) + (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! syntax-dispatch +(set! $sc-dispatch (lambda (e p) (cond ((eq? p 'any) (list e)) ((syntax-object? e) - (match* (unannotate (syntax-object-expression e)) - p (syntax-object-wrap e) '() (syntax-object-module e))) - (else (match* (unannotate e) p empty-wrap '() #f))))) + (match* (syntax-object-expression e) + p (syntax-object-wrap e) '() (syntax-object-module e))) + (else (match* e p empty-wrap '() #f))))) -(set! sc-chi chi) )) ) @@ -2173,7 +2253,7 @@ (lambda (x) (syntax-case x () ((let* ((x v) ...) e1 e2 ...) - (andmap identifier? (syntax (x ...))) + (and-map identifier? (syntax (x ...))) (let f ((bindings (syntax ((x v) ...)))) (if (null? bindings) (syntax (let () e1 e2 ...)) @@ -2190,7 +2270,9 @@ (syntax-case s () (() v) ((e) (syntax e)) - (_ (syntax-error orig-x)))) + (_ (syntax-violation + 'do "bad step expression" + orig-x s)))) (syntax (var ...)) (syntax (step ...))))) (syntax-case (syntax (e1 ...)) () @@ -2238,12 +2320,22 @@ (syntax p) (quasicons (syntax (quote unquote)) (quasi (syntax (p)) (- lev 1))))) + ((unquote . args) + (= lev 0) + (syntax-violation 'unquote + "unquote takes exactly one argument" + p (syntax (unquote . args)))) (((unquote-splicing p) . q) (if (= lev 0) (quasiappend (syntax p) (quasi (syntax q) lev)) (quasicons (quasicons (syntax (quote unquote-splicing)) (quasi (syntax (p)) (- lev 1))) (quasi (syntax q) lev)))) + (((unquote-splicing . args) . q) + (= lev 0) + (syntax-violation 'unquote-splicing + "unquote-splicing takes exactly one argument" + p (syntax (unquote-splicing . args)))) ((quasiquote p) (quasicons (syntax (quote quasiquote)) (quasi (syntax (p)) (+ lev 1)))) @@ -2263,29 +2355,29 @@ (let f ((x (read p))) (if (eof-object? x) (begin (close-input-port p) '()) - (cons (datum->syntax-object k x) + (cons (datum->syntax k x) (f (read p)))))))) (syntax-case x () ((k filename) - (let ((fn (syntax-object->datum (syntax filename)))) + (let ((fn (syntax->datum (syntax filename)))) (with-syntax (((exp ...) (read-file fn (syntax k)))) (syntax (begin exp ...)))))))) (define-syntax unquote - (lambda (x) - (syntax-case x () - ((_ e) - (error 'unquote - "expression ,~s not valid outside of quasiquote" - (syntax-object->datum (syntax e))))))) + (lambda (x) + (syntax-case x () + ((_ e) + (syntax-violation 'unquote + "expression not valid outside of quasiquote" + x))))) (define-syntax unquote-splicing - (lambda (x) - (syntax-case x () - ((_ e) - (error 'unquote-splicing - "expression ,@~s not valid outside of quasiquote" - (syntax-object->datum (syntax e))))))) + (lambda (x) + (syntax-case x () + ((_ e) + (syntax-violation 'unquote-splicing + "expression not valid outside of quasiquote" + x))))) (define-syntax case (lambda (x) @@ -2298,14 +2390,15 @@ ((else e1 e2 ...) (syntax (begin e1 e2 ...))) (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...)) (begin e1 e2 ...)))) - (_ (syntax-error x))) + (_ (syntax-violation 'case "bad clause" x clause))) (with-syntax ((rest (f (car clauses) (cdr clauses)))) (syntax-case clause (else) (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...)) (begin e1 e2 ...) rest))) - (_ (syntax-error x)))))))) + (_ (syntax-violation 'case "bad clause" x + clause)))))))) (syntax (let ((t e)) body))))))) (define-syntax identifier-syntax diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm index de2aeb2de..7b1c11cc1 100644 --- a/module/ice-9/r4rs.scm +++ b/module/ice-9/r4rs.scm @@ -17,6 +17,9 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + ;;;; apply and call-with-current-continuation @@ -186,28 +189,3 @@ procedures, their behavior is implementation dependent." (lambda (p) (with-error-to-port p thunk)))) (define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) - - -;;;; Loading - -(if (not (defined? '%load-verbosely)) - (define %load-verbosely #f)) -(define (assert-load-verbosity v) (set! %load-verbosely v)) - -(define (%load-announce file) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display "loading ") - (display file) - (newline) - (force-output))))) - -(set! %load-hook %load-announce) - -(define (load name . reader) - (with-fluid* current-reader (and (pair? reader) (car reader)) - (lambda () - (start-stack 'load-stack - (primitive-load name))))) diff --git a/module/ice-9/stack-catch.scm b/module/ice-9/stack-catch.scm index 2f4b3d145..a54267617 100644 --- a/module/ice-9/stack-catch.scm +++ b/module/ice-9/stack-catch.scm @@ -40,4 +40,4 @@ this call to @code{catch}." (catch key thunk handler - pre-unwind-handler-dispatch)) + default-pre-unwind-handler)) diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index d8fdeb4c9..22391a8c8 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -17,197 +17,15 @@ (define-module (ice-9 syncase) - :use-module (ice-9 expand-support) - :use-module (ice-9 debug) - :use-module (ice-9 threads) - :export-syntax (sc-macro define-syntax define-syntax-public - fluid-let-syntax - identifier-syntax let-syntax - letrec-syntax syntax syntax-case syntax-rules - with-syntax - include) - :export (sc-expand sc-expand3 install-global-transformer - syntax-dispatch syntax-error bound-identifier=? - datum->syntax-object free-identifier=? - generate-temporaries identifier? syntax-object->datum - void syncase) - :replace (eval eval-when)) + ) - - -(define (annotation? x) #f) - -(define sc-macro - (procedure->memoizing-macro - (lambda (exp env) - (save-module-excursion - (lambda () - ;; Because memoization happens lazily, env's module isn't - ;; necessarily the current module. - (set-current-module (eval-closure-module (car (last-pair env)))) - (strip-expansion-structures (sc-expand exp))))))) - -;;; Exported variables - -(define sc-expand #f) -(define sc-expand3 #f) -(define sc-chi #f) -(define install-global-transformer #f) -(define syntax-dispatch #f) -(define syntax-error #f) - -(define bound-identifier=? #f) -(define datum->syntax-object #f) -(define free-identifier=? #f) -(define generate-temporaries #f) -(define identifier? #f) -(define syntax-object->datum #f) - -(define primitive-syntax '(quote lambda letrec if set! begin define or - and let let* cond do quasiquote unquote - unquote-splicing case @ @@)) - -(for-each (lambda (symbol) - (set-symbol-property! symbol 'primitive-syntax #t)) - primitive-syntax) - -;;; Hooks needed by the syntax-case macro package - -(define (void) *unspecified*) - -(define andmap - (lambda (f first . rest) - (or (null? first) - (if (null? rest) - (let andmap ((first first)) - (let ((x (car first)) (first (cdr first))) - (if (null? first) - (f x) - (and (f x) (andmap first))))) - (let andmap ((first first) (rest rest)) - (let ((x (car first)) - (xr (map car rest)) - (first (cdr first)) - (rest (map cdr rest))) - (if (null? first) - (apply f (cons x xr)) - (and (apply f (cons x xr)) (andmap first rest))))))))) - -(define (error who format-string why what) - (start-stack 'syncase-stack - (scm-error 'misc-error - who - "~A ~S" - (list why what) - '()))) - -(define the-syncase-module (current-module)) - -(define guile-macro - (cons 'external-macro - (lambda (e r w s mod) - (let ((e (syntax-object->datum e))) - (if (symbol? e) - ;; pass the expression through - e - (let* ((mod (resolve-module mod)) - (m (module-ref mod (car e)))) - (if (eq? (macro-type m) 'syntax) - ;; pass the expression through - e - ;; perform Guile macro transform - (let ((e ((macro-transformer m) - (strip-expansion-structures e) - (append r (list (module-eval-closure mod)))))) - (if (variable? e) - e - (if (null? r) - (sc-expand e) - (sc-chi e r w (module-name mod)))))))))))) - -(define generated-symbols (make-weak-key-hash-table 1019)) - -;; We define our own gensym here because the Guile built-in one will -;; eventually produce uninterned and unreadable symbols (as needed for -;; safe macro expansions) and will the be inappropriate for dumping to -;; pssyntax.pp. -;; -;; syncase is supposed to only require that gensym produce unique -;; readable symbols, and they only need be unique with respect to -;; multiple calls to gensym, not globally unique. -;; -(define gensym - (let ((counter 0)) - - (define next-id - (if (provided? 'threads) - (let ((symlock (make-mutex))) - (lambda () - (let ((result #f)) - (with-mutex symlock - (set! result counter) - (set! counter (+ counter 1))) - result))) - ;; faster, non-threaded case. - (lambda () - (let ((result counter)) - (set! counter (+ counter 1)) - result)))) - - ;; actual gensym body code. - (lambda (. rest) - (let* ((next-val (next-id)) - (valstr (number->string next-val))) - (cond - ((null? rest) - (string->symbol (string-append "syntmp-" valstr))) - ((null? (cdr rest)) - (string->symbol (string-append "syntmp-" (car rest) "-" valstr))) - (else - (error - (string-append - "syncase's gensym expected 0 or 1 arguments, got " - (length rest))))))))) - -;;; Load the preprocessed code - -(let ((old-debug #f) - (old-read #f)) - (dynamic-wind (lambda () - (set! old-debug (debug-options)) - (set! old-read (read-options))) - (lambda () - (debug-disable 'debug 'procnames) - (read-disable 'positions) - (load-from-path "ice-9/psyntax-pp")) - (lambda () - (debug-options old-debug) - (read-options old-read)))) - -(define internal-eval (nested-ref the-scm-module '(%app modules guile eval))) - -(define (eval x environment) - (internal-eval (if (and (pair? x) - (equal? (car x) "noexpand")) - (strip-expansion-structures (cadr x)) - (strip-expansion-structures (sc-expand x))) - environment)) +(issue-deprecation-warning + "Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary.") ;;; Hack to make syncase macros work in the slib module -(let ((m (nested-ref the-root-module '(%app modules ice-9 slib)))) - (if m - (set-object-property! (module-local-variable m 'define) - '*sc-expander* - '(define)))) - -(define (syncase exp) - (strip-expansion-structures (sc-expand exp))) - -(set-module-transformer! the-syncase-module syncase) - -(define-syntax define-syntax-public - (syntax-rules () - ((_ name rules ...) - (begin - ;(eval-case ((load-toplevel) (export-syntax name))) - (define-syntax name rules ...))))) +;; FIXME wingo is this still necessary? +;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib)))) +;; (if m +;; (set-object-property! (module-local-variable m 'define) +;; '*sc-expander* +;; '(define)))) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index bd0f7b745..e07d766eb 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -32,21 +32,71 @@ ;;; Code: (define-module (ice-9 threads) - :export (par-map + :export (begin-thread + parallel + letpar + make-thread + with-mutex + monitor + + par-map par-for-each n-par-map n-par-for-each n-for-each-par-map - %thread-handler) - :export-syntax (begin-thread - parallel - letpar - make-thread - with-mutex - monitor)) + %thread-handler)) +;;; Macros first, so that the procedures expand correctly. + +(define-syntax begin-thread + (syntax-rules () + ((_ e0 e1 ...) + (call-with-new-thread + (lambda () e0 e1 ...) + %thread-handler)))) + +(define-syntax parallel + (lambda (x) + (syntax-case x () + ((_ e0 ...) + (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) + (syntax + (let ((tmp0 (begin-thread e0)) + ...) + (values (join-thread tmp0) ...)))))))) + +(define-syntax letpar + (syntax-rules () + ((_ ((v e) ...) b0 b1 ...) + (call-with-values + (lambda () (parallel e ...)) + (lambda (v ...) + b0 b1 ...))))) + +(define-syntax make-thread + (syntax-rules () + ((_ proc arg ...) + (call-with-new-thread + (lambda () (proc arg ...)) + %thread-handler)))) + +(define-syntax with-mutex + (syntax-rules () + ((_ m e0 e1 ...) + (let ((x m)) + (dynamic-wind + (lambda () (lock-mutex x)) + (lambda () (begin e0 e1 ...)) + (lambda () (unlock-mutex x))))))) + +(define-syntax monitor + (syntax-rules () + ((_ first rest ...) + (with-mutex (make-mutex) + first rest ...)))) + (define (par-mapper mapper) (lambda (proc . arglists) (mapper join-thread @@ -171,52 +221,4 @@ of applying P-PROC on ARGLISTS." ;;; Set system thread handler (define %thread-handler thread-handler) -; --- MACROS ------------------------------------------------------- - -(define-macro (begin-thread . forms) - (if (null? forms) - '(begin) - `(call-with-new-thread - (lambda () - ,@forms) - %thread-handler))) - -(define-macro (parallel . forms) - (cond ((null? forms) '(values)) - ((null? (cdr forms)) (car forms)) - (else - (let ((vars (map (lambda (f) - (make-symbol "f")) - forms))) - `((lambda ,vars - (values ,@(map (lambda (v) `(join-thread ,v)) vars))) - ,@(map (lambda (form) `(begin-thread ,form)) forms)))))) - -(define-macro (letpar bindings . body) - (cond ((or (null? bindings) (null? (cdr bindings))) - `(let ,bindings ,@body)) - (else - (let ((vars (map car bindings))) - `((lambda ,vars - ((lambda ,vars ,@body) - ,@(map (lambda (v) `(join-thread ,v)) vars))) - ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings)))))) - -(define-macro (make-thread proc . args) - `(call-with-new-thread - (lambda () - (,proc ,@args)) - %thread-handler)) - -(define-macro (with-mutex m . body) - `(dynamic-wind - (lambda () (lock-mutex ,m)) - (lambda () (begin ,@body)) - (lambda () (unlock-mutex ,m)))) - -(define-macro (monitor first . rest) - `(with-mutex ,(make-mutex) - (begin - ,first ,@rest))) - ;;; threads.scm ends here diff --git a/module/ice-9/time.scm b/module/ice-9/time.scm index a7045969f..86ebcbff1 100644 --- a/module/ice-9/time.scm +++ b/module/ice-9/time.scm @@ -53,6 +53,6 @@ result)) (define-macro (time exp) - `(,time-proc (lambda () ,exp))) + `((@@ (ice-9 time) time-proc) (lambda () ,exp))) ;;; time.scm ends here diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index 2752934f9..df6199977 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -82,7 +82,7 @@ (if (program? x) (begin (display "----------------------------------------\n") (disassemble x)))) - (cddr (vector->list objs)))))) + (cdr (vector->list objs)))))) (else (error "bad load-program form" asm)))) diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm index 550a0b734..0112af5a4 100644 --- a/module/language/ecmascript/spec.scm +++ b/module/language/ecmascript/spec.scm @@ -33,7 +33,6 @@ #:title "Guile ECMAScript" #:version "3.0" #:reader (lambda () (read-ecmascript/1 (current-input-port))) - #:read-file read-ecmascript #:compilers `((ghil . ,compile-ghil)) ;; a pretty-printer would be interesting. #:printer write diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm index c813319d6..02187be05 100644 --- a/module/language/ghil/compile-glil.scm +++ b/module/language/ghil/compile-glil.scm @@ -187,7 +187,7 @@ (define (make-glil-var op env var) (case (ghil-var-kind var) ((argument) - (make-glil-argument op (ghil-var-index var))) + (make-glil-local op (ghil-var-index var))) ((local) (make-glil-local op (ghil-var-index var))) ((external) @@ -217,7 +217,9 @@ (set! stack (cons code stack)) (if loc (set! stack (cons (make-glil-source loc) stack)))) (define (var->binding var) - (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) + (list (ghil-var-name var) (let ((kind (ghil-var-kind var))) + (case kind ((argument) 'local) (else kind))) + (ghil-var-index var))) (define (push-bindings! loc vars) (if (not (null? vars)) (push-code! loc (make-glil-bind (map var->binding vars))))) @@ -496,7 +498,7 @@ (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) (nargs (allocate-indices-linearly! vars)) - (nlocs (allocate-locals! locs body)) + (nlocs (allocate-locals! locs body nargs)) (nexts (allocate-indices-linearly! exts))) ;; meta bindings (push-bindings! #f vars) @@ -509,7 +511,7 @@ (let ((v (car l))) (case (ghil-var-kind v) ((external) - (push-code! #f (make-glil-argument 'ref n)) + (push-code! #f (make-glil-local 'ref n)) (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) ;; compile body (comp body #t #f) @@ -523,8 +525,8 @@ ((null? l) n) (let ((v (car l))) (set! (ghil-var-index v) n)))) -(define (allocate-locals! vars body) - (let ((free '()) (nlocs 0)) +(define (allocate-locals! vars body nargs) + (let ((free '()) (nlocs nargs)) (define (allocate! var) (cond ((pair? free) diff --git a/module/language/glil.scm b/module/language/glil.scm index 01b680194..625760eaa 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -44,9 +44,6 @@ make-glil-const glil-const? glil-const-obj - make-glil-argument glil-argument? - glil-argument-op glil-argument-index - make-glil-local glil-local? glil-local-op glil-local-index @@ -87,7 +84,6 @@ () ( obj) ;; Variables - ( op index) ( op index) ( op depth index) ( op name) @@ -125,13 +121,12 @@ ((source ,props) (make-glil-source props)) ((void) (make-glil-void)) ((const ,obj) (make-glil-const obj)) - ((argument ,op ,index) (make-glil-argument op index)) ((local ,op ,index) (make-glil-local op index)) ((external ,op ,depth ,index) (make-glil-external op depth index)) ((toplevel ,op ,name) (make-glil-toplevel op name)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) - ((label ,label) (make-label ,label)) + ((label ,label) (make-label label)) ((branch ,inst ,label) (make-glil-branch inst label)) ((call ,inst ,nargs) (make-glil-call inst nargs)) ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra)) @@ -150,8 +145,6 @@ (() `(void)) (( obj) `(const ,obj)) ;; variables - (( op index) - `(argument ,op ,index)) (( op index) `(local ,op ,index)) (( op depth index) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index ffac9dbfb..4c92e0f5a 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -83,16 +83,15 @@ (define (make-closed-binding open-binding start end) (make-binding (car open-binding) (cadr open-binding) (caddr open-binding) start end)) -(define (open-binding bindings vars nargs start) +(define (open-binding bindings vars start) (cons (acons start (map (lambda (v) (pmatch v - ((,name argument ,i) (make-open-binding name #f i)) - ((,name local ,i) (make-open-binding name #f (+ nargs i))) + ((,name local ,i) (make-open-binding name #f i)) ((,name external ,i) (make-open-binding name #t i)) - (else (error "unknown binding type" name type)))) + (else (error "unknown binding type" v)))) vars) (car bindings)) (cdr bindings))) @@ -129,13 +128,13 @@ (define (compile-assembly glil) (receive (code . _) - (glil->assembly glil 0 '() '(()) '() '() #f -1) + (glil->assembly glil '() '(()) '() '() #f -1) (car code))) (define (make-object-table objects) (and (not (null? objects)) (list->vector (cons #f objects)))) -(define (glil->assembly glil nargs nexts-stack bindings +(define (glil->assembly glil nexts-stack bindings source-alist label-alist object-alist addr) (define (emit-code x) (values (map assembly-pack x) bindings source-alist label-alist object-alist)) @@ -159,7 +158,7 @@ addr)) (else (receive (subcode bindings source-alist label-alist object-alist) - (glil->assembly (car body) nargs nexts-stack bindings + (glil->assembly (car body) nexts-stack bindings source-alist label-alist object-alist addr) (lp (cdr body) (append (reverse subcode) code) bindings source-alist label-alist object-alist @@ -196,14 +195,14 @@ (( vars) (values '() - (open-binding bindings vars nargs addr) + (open-binding bindings vars addr) source-alist label-alist object-alist)) (( vars rest) (values `((truncate-values ,(length vars) ,(if rest 1 0))) - (open-binding bindings vars nargs addr) + (open-binding bindings vars addr) source-alist label-alist object-alist)) @@ -238,16 +237,11 @@ (emit-code/object `((object-ref ,i)) object-alist))))) - (( op index) + (( op index) (emit-code (if (eq? op 'ref) `((local-ref ,index)) `((local-set ,index))))) - (( op index) - (emit-code (if (eq? op 'ref) - `((local-ref ,(+ nargs index))) - `((local-set ,(+ nargs index)))))) - (( op depth index) (emit-code (let lp ((d depth) (n 0) (stack nexts-stack)) (if (> d 0) @@ -318,7 +312,12 @@ (error "Unknown instruction:" inst)) (let ((pops (instruction-pops inst))) (cond ((< pops 0) - (emit-code `((,inst ,nargs)))) + (case (instruction-length inst) + ((1) (emit-code `((,inst ,nargs)))) + ((2) (emit-code `((,inst ,(quotient nargs 256) + ,(modulo nargs 256))))) + (else (error "Unknown length for variable-arg instruction:" + inst (instruction-length inst))))) ((= pops nargs) (emit-code `((,inst)))) (else diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm index a98c39975..a47bd80b2 100644 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.scm @@ -175,15 +175,11 @@ (1+ pos))) ((local-ref ,n) (lp (cdr in) (cons *placeholder* stack) - (cons (if (< n nargs) - (make-glil-argument 'ref n) - (make-glil-local 'ref (- n nargs))) + (cons (make-glil-local 'ref n) out) (+ pos 2))) ((local-set ,n) (lp (cdr in) (cdr stack) - (cons (if (< n nargs) - (make-glil-argument 'set n) - (make-glil-local 'set (- n nargs))) + (cons (make-glil-local 'set n) (emit-constants (list-head stack 1) out)) (+ pos 2))) ((br-if-not ,l) diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm deleted file mode 100644 index 4ac973620..000000000 --- a/module/language/scheme/amatch.scm +++ /dev/null @@ -1,37 +0,0 @@ -(define-module (language scheme amatch) - #:use-module (ice-9 syncase) - #:export (amatch apat)) -;; FIXME: shouldn't have to export apat... - -;; This is exactly the same as pmatch except that it unpacks annotations -;; as needed. - -(define-syntax amatch - (syntax-rules (else guard) - ((_ (op arg ...) cs ...) - (let ((v (op arg ...))) - (amatch v cs ...))) - ((_ v) (if #f #f)) - ((_ v (else e0 e ...)) (begin e0 e ...)) - ((_ v (pat (guard g ...) e0 e ...) cs ...) - (let ((fk (lambda () (amatch v cs ...)))) - (apat v pat - (if (and g ...) (begin e0 e ...) (fk)) - (fk)))) - ((_ v (pat e0 e ...) cs ...) - (let ((fk (lambda () (amatch v cs ...)))) - (apat v pat (begin e0 e ...) (fk)))))) - -(define-syntax apat - (syntax-rules (_ quote unquote) - ((_ v _ kt kf) kt) - ((_ v () kt kf) (if (null? v) kt kf)) - ((_ v (quote lit) kt kf) - (if (equal? v (quote lit)) kt kf)) - ((_ v (unquote var) kt kf) (let ((var v)) kt)) - ((_ v (x . y) kt kf) - (if (apair? v) - (let ((vx (acar v)) (vy (acdr v))) - (apat vx x (apat vy y kt kf) kf)) - kf)) - ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf)))) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 86234059e..8d8332c34 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -27,13 +27,11 @@ #:use-module (system vm objcode) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) - #:use-module (ice-9 expand-support) - #:use-module ((ice-9 syncase) #:select (sc-macro)) + #:use-module (language tree-il) #:use-module ((system base compile) #:select (syntax-error)) #:export (compile-ghil translate-1 *translate-table* define-scheme-translator)) - ;;; environment := #f ;;; | MODULE ;;; | COMPILE-ENV @@ -70,12 +68,14 @@ (and=> (cenv-module e) set-current-module) (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) - (let ((x (make-ghil-lambda env #f vars #f '() - (translate-1 env #f x))) - (cenv (make-cenv (current-module) - (ghil-env-parent env) - (if e (cenv-externals e) '())))) - (values x cenv cenv))))))) + (let ((x (tree-il->scheme + (sc-expand x 'c '(compile load eval))))) + (let ((x (make-ghil-lambda env #f vars #f '() + (translate-1 env #f x))) + (cenv (make-cenv (current-module) + (ghil-env-parent env) + (if e (cenv-externals e) '())))) + (values x cenv cenv)))))))) ;;; @@ -104,9 +104,6 @@ (let* ((mod (current-module)) (val (cond ((symbol? head) (module-ref/safe mod head)) - ;; allow macros to be unquoted into the output of a macro - ;; expansion - ((macro? head) head) ((pmatch head ((@ ,modname ,sym) (module-ref/safe (resolve-interface modname) sym)) @@ -117,21 +114,6 @@ (cond ((hashq-ref *translate-table* val)) - ((defmacro? val) - (lambda (env loc exp) - (retrans (apply (defmacro-transformer val) (cdr exp))))) - - ((eq? val sc-macro) - ;; syncase! - (let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3))) - (lambda (env loc exp) - (retrans - (strip-expansion-structures - (sc-expand3 exp 'c '(compile load eval))))))) - - ((primitive-macro? val) - (syntax-error #f "unhandled primitive macro" head)) - ((macro? val) (syntax-error #f "unknown kind of macro" head)) @@ -180,7 +162,7 @@ (define-macro (define-scheme-translator sym . clauses) `(hashq-set! (@ (language scheme compile-ghil) *translate-table*) - ,sym + (module-ref (current-module) ',sym) (lambda (e l exp) (define (retrans x) ((@ (language scheme compile-ghil) translate-1) @@ -432,16 +414,6 @@ (,args (-> (values (map retrans args))))) -(define-scheme-translator compile-time-environment - ;; (compile-time-environment) - ;; => (MODULE LEXICALS . EXTERNALS) - (() - (-> (inline 'cons - (list (retrans '(current-module)) - (-> (inline 'cons - (list (-> (reified-env)) - (-> (inline 'externals '())))))))))) - (define (lookup-apply-transformer proc) (cond ((eq? proc values) (lambda (e l args) diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm new file mode 100644 index 000000000..4635abc8a --- /dev/null +++ b/module/language/scheme/compile-tree-il.scm @@ -0,0 +1,64 @@ +;;; Guile Scheme specification + +;; Copyright (C) 2001 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 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language scheme compile-tree-il) + #:use-module (language tree-il) + #:export (compile-tree-il)) + +;;; environment := #f +;;; | MODULE +;;; | COMPILE-ENV +;;; compile-env := (MODULE LEXICALS . EXTERNALS) +(define (cenv-module env) + (cond ((not env) #f) + ((module? env) env) + ((and (pair? env) (module? (car env))) (car env)) + (else (error "bad environment" env)))) + +(define (cenv-lexicals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cadr env)) + (else (error "bad environment" env)))) + +(define (cenv-externals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cddr env)) + (else (error "bad environment" env)))) + +(define (make-cenv module lexicals externals) + (cons module (cons lexicals externals))) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) + +(define (compile-tree-il x e opts) + (save-module-excursion + (lambda () + (and=> (cenv-module e) set-current-module) + (let* ((x (sc-expand x 'c '(compile load eval))) + (cenv (make-cenv (current-module) + (cenv-lexicals e) (cenv-externals e)))) + (values x cenv cenv))))) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm new file mode 100644 index 000000000..c4903d87f --- /dev/null +++ b/module/language/scheme/decompile-tree-il.scm @@ -0,0 +1,27 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001,2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language scheme decompile-tree-il) + #:use-module (language tree-il) + #:export (decompile-tree-il)) + +(define (decompile-tree-il x env opts) + (values (tree-il->scheme x) env)) diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm deleted file mode 100644 index 2ffefb318..000000000 --- a/module/language/scheme/expand.scm +++ /dev/null @@ -1,307 +0,0 @@ -;;; Guile Scheme specification - -;; Copyright (C) 2001 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 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 General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define-module (language scheme expand) - #:use-module (language scheme amatch) - #:use-module (ice-9 expand-support) - #:use-module (ice-9 optargs) - #:use-module ((ice-9 syncase) #:select (sc-macro)) - #:use-module ((system base compile) #:select (syntax-error)) - #:export (expand *expand-table* define-scheme-expander)) - -(define (aref x) (if (annotation? x) (annotation-expression x) x)) -(define (apair? x) (pair? (aref x))) -(define (acar x) (car (aref x))) -(define (acdr x) (cdr (aref x))) -(define (acaar x) (acar (acar x))) -(define (acdar x) (acdr (acar x))) -(define (acadr x) (acar (acdr x))) -(define (acddr x) (acdr (acdr x))) -(define (aloc x) (and (annotation? x) (annotation-source x))) -(define (re-annotate x y) - (if (and (annotation? x) (not (annotation? y))) - (make-annotation y (annotation-source x)) - y)) -(define-macro (-> exp) `(re-annotate x ,exp)) - -(define* (expand x #:optional (mod (current-module)) (once? #f)) - (define re-expand - (if once? - (lambda (x) x) - (lambda (x) (expand x mod once?)))) - (let ((exp (if (annotation? x) (annotation-expression x) x))) - (cond - ((pair? exp) - (let ((head (car exp)) (tail (cdr exp))) - (cond - ;; allow macros to be unquoted into the output of a macro - ;; expansion - ((or (symbol? head) (macro? head)) - (let ((val (cond - ((macro? head) head) - ((module-variable mod head) - => (lambda (var) - ;; unbound vars can happen if the module - ;; definition forward-declared them - (and (variable-bound? var) (variable-ref var)))) - (else #f)))) - (cond - ((hashq-ref *expand-table* val) - => (lambda (expand1) (expand1 x re-expand))) - - ((defmacro? val) - (re-expand (-> (apply (defmacro-transformer val) - (deannotate tail))))) - - ((eq? val sc-macro) - ;; syncase! - (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure)) - (sc-expand3 (@@ (ice-9 syncase) sc-expand3))) - (re-expand - (with-fluids ((eec (module-eval-closure mod))) - ;; fixme -- use ewes fluid? - (sc-expand3 exp 'c '(compile load eval)))))) - - ((primitive-macro? val) - (syntax-error (aloc x) "unhandled primitive macro" head)) - - ((macro? val) - (syntax-error (aloc x) "unknown kind of macro" head)) - - (else - (-> (cons head (map re-expand tail))))))) - - (else - (-> (map re-expand exp)))))) - - (else x)))) - - -(define *expand-table* (make-hash-table)) - -(define-macro (define-scheme-expander sym . clauses) - `(hashq-set! (@ (language scheme expand) *expand-table*) - ,sym - (lambda (x re-expand) - (define syntax-error (@ (system base compile) syntax-error)) - (amatch (acdr x) - ,@clauses - ,@(if (assq 'else clauses) '() - `((else - (syntax-error (aloc x) (format #f "bad ~A" ',sym) x)))))))) - -(define-scheme-expander quote - ;; (quote OBJ) - ((,obj) x)) - -(define-scheme-expander quasiquote - ;; (quasiquote OBJ) - ((,obj) - (-> `(,'quasiquote - ,(let lp ((x obj) (level 0)) - (cond ((not (apair? x)) x) - ;; FIXME: hygiene regarding imported , / ,@ rebinding - ((memq (acar x) '(unquote unquote-splicing)) - (amatch (acdr x) - ((,obj) - (cond - ((zero? level) - (-> `(,(acar x) ,(re-expand obj)))) - (else - (-> `(,(acar x) ,(lp obj (1- level))))))) - (else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x)))) - ((eq? (acar x) 'quasiquote) - (amatch (acdr x) - ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level))))) - (else (syntax-error (aloc x) "bad quasiquote" x)))) - (else (-> (cons (lp (acar x) level) (lp (acdr x) level)))))))))) - -(define-scheme-expander define - ;; (define NAME VAL) - ((,name ,val) (guard (symbol? name)) - (-> `(define ,name ,(re-expand val)))) - ;; (define (NAME FORMALS...) BODY...) - (((,name . ,formals) . ,body) (guard (symbol? name)) - ;; -> (define NAME (lambda FORMALS BODY...)) - (re-expand (-> `(define ,name (lambda ,formals . ,body)))))) - -(define-scheme-expander set! - ;; (set! (NAME ARGS...) VAL) - (((,name . ,args) ,val) (guard (symbol? name) - (not (eq? name '@)) (not (eq? name '@@))) - ;; -> ((setter NAME) ARGS... VAL) - (re-expand (-> `((setter ,name) ,@args ,val)))) - - ;; (set! NAME VAL) - ((,name ,val) (guard (symbol? name)) - (-> `(set! ,name ,(re-expand val))))) - -(define-scheme-expander if - ;; (if TEST THEN [ELSE]) - ((,test ,then) - (-> `(if ,(re-expand test) ,(re-expand then)))) - ((,test ,then ,else) - (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else))))) - -(define-scheme-expander and - ;; (and EXPS...) - (,tail - (-> `(and . ,(map re-expand tail))))) - -(define-scheme-expander or - ;; (or EXPS...) - (,tail - (-> `(or . ,(map re-expand tail))))) - -(define-scheme-expander begin - ;; (begin EXPS...) - ((,single-exp) - (-> (re-expand single-exp))) - (,tail - (-> `(begin . ,(map re-expand tail))))) - -(define (valid-bindings? bindings . it-is-for-do) - (define (valid-binding? b) - (amatch b - ((,sym ,var) (guard (symbol? sym)) #t) - ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) - (else #f))) - (and (list? (aref bindings)) - (and-map valid-binding? (aref bindings)))) - -(define-scheme-expander let - ;; (let NAME ((SYM VAL) ...) BODY...) - ((,name ,bindings . ,body) (guard (symbol? name) - (valid-bindings? bindings)) - ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) - (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings)) - . ,body))) - (,name . ,(map acadr (aref bindings))))))) - - ((() . ,body) - (re-expand (expand-internal-defines body))) - - ;; (let ((SYM VAL) ...) BODY...) - ((,bindings . ,body) (guard (valid-bindings? bindings)) - (-> `(let ,(map (lambda (x) - ;; nb, relies on -> non-hygiene - (-> `(,(acar x) ,(re-expand (acadr x))))) - (aref bindings)) - ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander let* - ;; (let* ((SYM VAL) ...) BODY...) - ((() . ,body) - (re-expand (-> `(let () . ,body)))) - ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) - (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body)))))) - -(define-scheme-expander letrec - ;; (letrec ((SYM VAL) ...) BODY...) - ((,bindings . ,body) (guard (valid-bindings? bindings)) - (-> `(letrec ,(map (lambda (x) - ;; nb, relies on -> non-hygiene - (-> `(,(acar x) ,(re-expand (acadr x))))) - (aref bindings)) - ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander cond - ;; (cond (CLAUSE BODY...) ...) - (() (-> '(begin))) - (((else . ,body)) (re-expand (-> `(begin ,@body)))) - (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest))))) - (((,test => ,proc) . ,rest) - ;; FIXME hygiene! - (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))) - (((,test . ,body) . ,rest) - (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest)))))) - -(define-scheme-expander case - ;; (case EXP ((KEY...) BODY...) ...) - ((,exp . ,clauses) - ;; FIXME hygiene! - (re-expand - (->`(let ((_t ,exp)) - ,(let loop ((ls clauses)) - (cond ((null? ls) '(begin)) - ((eq? (acaar ls) 'else) `(begin ,@(acdar ls))) - (else `(if (memv _t ',(acaar ls)) - (begin ,@(acdar ls)) - ,(loop (acdr ls))))))))))) - -(define-scheme-expander do - ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) - ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t)) - (let ((sym (map acar (aref bindings))) - (val (map acadr (aref bindings))) - (update (map acddr (aref bindings)))) - (define (next s x) (if (pair? x) (car x) s)) - (re-expand - ;; FIXME hygiene! - (-> `(letrec ((_l (lambda ,sym - (if ,test - (begin ,@result) - (begin ,@body - (_l ,@(map next sym update))))))) - (_l ,@val))))))) - -(define-scheme-expander lambda - ;; (lambda FORMALS BODY...) - ((,formals ,docstring ,body1 . ,body) (guard (string? docstring)) - (-> `(lambda ,formals ,docstring ,(expand-internal-defines - (map re-expand (cons body1 body)))))) - ((,formals . ,body) - (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander delay - ;; FIXME not hygienic - ((,expr) - (re-expand `(make-promise (lambda () ,expr))))) - -(define-scheme-expander @ - ((,modname ,sym) - x)) - -(define-scheme-expander @@ - ((,modname ,sym) - x)) - -(define-scheme-expander eval-when - ((,when . ,body) (guard (list? when) (and-map symbol? when)) - (if (memq 'compile when) - (primitive-eval `(begin . ,body))) - (if (memq 'load when) - (-> `(begin . ,body)) - (-> `(begin))))) - -;;; Hum, I don't think this takes imported modifications to `define' -;;; properly into account. (Lexical bindings are OK because of alpha -;;; renaming.) -(define (expand-internal-defines body) - (let loop ((ls body) (ds '())) - (amatch ls - (() (syntax-error l "bad body" body)) - (((define ,name ,val) . _) - (loop (acdr ls) (cons (list name val) ds))) - (else - (if (null? ds) - (if (null? (cdr ls)) (car ls) `(begin ,@ls)) - `(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls)))))))) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 8f958eb63..cec2693aa 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -22,6 +22,8 @@ (define-module (language scheme spec) #:use-module (system base language) #:use-module (language scheme compile-ghil) + #:use-module (language scheme compile-tree-il) + #:use-module (language scheme decompile-tree-il) #:export (scheme)) ;;; @@ -30,12 +32,6 @@ (read-enable 'positions) -(define (read-file port) - (do ((x (read port) (read port)) - (l '() (cons x l))) - ((eof-object? x) - (cons 'begin (reverse! l))))) - ;;; ;;; Language definition ;;; @@ -44,8 +40,9 @@ #:title "Guile Scheme" #:version "0.5" #:reader read - #:read-file read-file - #:compilers `((ghil . ,compile-ghil)) + #:compilers `((tree-il . ,compile-tree-il) + (ghil . ,compile-ghil)) + #:decompilers `((tree-il . ,decompile-tree-il)) #:evaluator (lambda (x module) (primitive-eval x)) #:printer write ) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm new file mode 100644 index 000000000..335031182 --- /dev/null +++ b/module/language/tree-il.scm @@ -0,0 +1,359 @@ +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (language tree-il) + #:use-module (system base pmatch) + #:use-module (system base syntax) + #:export (tree-il-src + + void? make-void void-src + const? make-const const-src const-exp + primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name + lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym + lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp + module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? + module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp + toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name + toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp + toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp + conditional? make-conditional conditional-src conditional-test conditional-then conditional-else + application? make-application application-src application-proc application-args + sequence? make-sequence sequence-src sequence-exps + lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body + let? make-let let-src let-names let-vars let-vals let-exp + letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp + + parse-tree-il + unparse-tree-il + tree-il->scheme + + post-order! + pre-order!)) + +(define-type ( #:common-slots (src)) + () + ( exp) + ( name) + ( name gensym) + ( name gensym exp) + ( mod name public?) + ( mod name public? exp) + ( name) + ( name exp) + ( name exp) + ( test then else) + ( proc args) + ( exps) + ( names vars meta body) + ( names vars vals exp) + ( names vars vals exp)) + + + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (pair? props) props)))) + +(define (parse-tree-il exp) + (let ((loc (location exp)) + (retrans (lambda (x) (parse-tree-il x)))) + (pmatch exp + ((void) + (make-void loc)) + + ((apply ,proc . ,args) + (make-application loc (retrans proc) (map retrans args))) + + ((if ,test ,then ,else) + (make-conditional loc (retrans test) (retrans then) (retrans else))) + + ((primitive ,name) (guard (symbol? name)) + (make-primitive-ref loc name)) + + ((lexical ,name) (guard (symbol? name)) + (make-lexical-ref loc name name)) + + ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) + (make-lexical-ref loc name sym)) + + ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) + (make-lexical-set loc name sym (retrans exp))) + + ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #t)) + + ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #t (retrans exp))) + + ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #f)) + + ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #f (retrans exp))) + + ((toplevel ,name) (guard (symbol? name)) + (make-toplevel-ref loc name)) + + ((set! (toplevel ,name) ,exp) (guard (symbol? name)) + (make-toplevel-set loc name (retrans exp))) + + ((define ,name ,exp) (guard (symbol? name)) + (make-toplevel-define loc name (retrans exp))) + + ((lambda ,names ,vars ,exp) + (make-lambda loc names vars '() (retrans exp))) + + ((lambda ,names ,vars ,meta ,exp) + (make-lambda loc names vars meta (retrans exp))) + + ((const ,exp) + (make-const loc exp)) + + ((begin . ,exps) + (make-sequence loc (map retrans exps))) + + ((let ,names ,vars ,vals ,exp) + (make-let loc names vars (map retrans vals) (retrans exp))) + + ((letrec ,names ,vars ,vals ,exp) + (make-letrec loc names vars (map retrans vals) (retrans exp))) + + (else + (error "unrecognized tree-il" exp))))) + +(define (unparse-tree-il tree-il) + (record-case tree-il + (() + '(void)) + + (( proc args) + `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) + + (( test then else) + `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else))) + + (( name) + `(primitive ,name)) + + (( name gensym) + `(lexical ,name ,gensym)) + + (( name gensym exp) + `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) + + (( mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + (( mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) + + (( name) + `(toplevel ,name)) + + (( name exp) + `(set! (toplevel ,name) ,(unparse-tree-il exp))) + + (( name exp) + `(define ,name ,(unparse-tree-il exp))) + + (( names vars meta body) + `(lambda ,names ,vars ,meta ,(unparse-tree-il body))) + + (( exp) + `(const ,exp)) + + (( exps) + `(begin ,@(map unparse-tree-il exps))) + + (( names vars vals exp) + `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))) + + (( names vars vals exp) + `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))))) + +(define (tree-il->scheme e) + (cond ((list? e) + (map tree-il->scheme e)) + ((pair? e) + (cons (tree-il->scheme (car e)) + (tree-il->scheme (cdr e)))) + ((record? e) + (record-case e + (() + '(if #f #f)) + + (( proc args) + `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) + + (( test then else) + (if (void? else) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then)) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))) + + (( name) + name) + + (( name gensym) + gensym) + + (( name gensym exp) + `(set! ,gensym ,(tree-il->scheme exp))) + + (( mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + (( mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) + + (( name) + name) + + (( name exp) + `(set! ,name ,(tree-il->scheme exp))) + + (( name exp) + `(define ,name ,(tree-il->scheme exp))) + + (( vars meta body) + `(lambda ,vars + ,@(cond ((assq-ref meta 'documentation) => list) (else '())) + ,(tree-il->scheme body))) + + (( exp) + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))) + + (( exps) + `(begin ,@(map tree-il->scheme exps))) + + (( vars vals exp) + `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))) + + (( vars vals exp) + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))))) + (else e))) + +(define (post-order! f x) + (let lp ((x x)) + (record-case x + (() + (or (f x) x)) + + (( proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args)) + (or (f x) x)) + + (( test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name gensym) + (or (f x) x)) + + (( name gensym exp) + (set! (lexical-set-exp x) (lp exp)) + (or (f x) x)) + + (( mod name public?) + (or (f x) x)) + + (( mod name public? exp) + (set! (module-set-exp x) (lp exp)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name exp) + (set! (toplevel-set-exp x) (lp exp)) + (or (f x) x)) + + (( name exp) + (set! (toplevel-define-exp x) (lp exp)) + (or (f x) x)) + + (( vars meta body) + (set! (lambda-body x) (lp body)) + (or (f x) x)) + + (( exp) + (or (f x) x)) + + (( exps) + (set! (sequence-exps x) (map lp exps)) + (or (f x) x)) + + (( vars vals exp) + (set! (let-vals x) (map lp vals)) + (set! (let-exp x) (lp exp)) + (or (f x) x)) + + (( vars vals exp) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-exp x) (lp exp)) + (or (f x) x))))) + +(define (pre-order! f x) + (let lp ((x x)) + (let ((x (or (f x) x))) + (record-case x + (( proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args))) + + (( test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else))) + + (( name gensym exp) + (set! (lexical-set-exp x) (lp exp))) + + (( mod name public? exp) + (set! (module-set-exp x) (lp exp))) + + (( name exp) + (set! (toplevel-set-exp x) (lp exp))) + + (( name exp) + (set! (toplevel-define-exp x) (lp exp))) + + (( vars meta body) + (set! (lambda-body x) (lp body))) + + (( exps) + (set! (sequence-exps x) (map lp exps))) + + (( vars vals exp) + (set! (let-vals x) (map lp vals)) + (set! (let-exp x) (lp exp))) + + (( vars vals exp) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-exp x) (lp exp))) + + (else #f)) + x))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm new file mode 100644 index 000000000..477f1fc2d --- /dev/null +++ b/module/language/tree-il/analyze.scm @@ -0,0 +1,235 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il analyze) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (analyze-lexicals)) + +;; allocation: the process of assigning a type and index to each var +;; a var is external if it is heaps; assigning index is easy +;; args are assigned in order +;; locals are indexed as their linear position in the binding path +;; (let (0 1) +;; (let (2 3) ...) +;; (let (2) ...)) +;; (let (2 3 4) ...)) +;; etc. +;; +;; This algorithm has the problem that variables are only allocated +;; indices at the end of the binding path. If variables bound early in +;; the path are not used in later portions of the path, their indices +;; will not be recycled. This problem is particularly egregious in the +;; expansion of `or': +;; +;; (or x y z) +;; -> (let ((a x)) (if a a (let ((b y)) (if b b z)))) +;; +;; As you can see, the `a' binding is only used in the ephemeral `then' +;; clause of the first `if', but its index would be reserved for the +;; whole of the `or' expansion. So we have a hack for this specific +;; case. A proper solution would be some sort of liveness analysis, and +;; not our linear allocation algorithm. +;; +;; allocation: +;; sym -> (local . index) | (heap level . index) +;; lambda -> (nlocs . nexts) + +(define (analyze-lexicals x) + ;; parents: lambda -> parent + ;; useful when we see a closed-over var, so we can calculate its + ;; coordinates (depth and index). + ;; bindings: lambda -> (sym ...) + ;; useful for two reasons: one, so we know how much space to allocate + ;; when we go into a lambda; and two, so that we know when to stop, + ;; when looking for closed-over vars. + ;; heaps: sym -> lambda + ;; allows us to heapify vars in an O(1) fashion + ;; refcounts: sym -> count + ;; allows us to detect the or-expansion an O(1) time + + (define (find-heap sym parent) + ;; fixme: check displaced lexicals here? + (if (memq sym (hashq-ref bindings parent)) + parent + (find-heap sym (hashq-ref parents parent)))) + + (define (analyze! x parent level) + (define (step y) (analyze! y parent level)) + (define (recur x parent) (analyze! x parent (1+ level))) + (record-case x + (( proc args) + (step proc) (for-each step args)) + + (( test then else) + (step test) (step then) (step else)) + + (( name gensym) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (if (and (not (memq gensym (hashq-ref bindings parent))) + (not (hashq-ref heaps gensym))) + (hashq-set! heaps gensym (find-heap gensym parent)))) + + (( name gensym exp) + (step exp) + (if (not (hashq-ref heaps gensym)) + (hashq-set! heaps gensym (find-heap gensym parent)))) + + (( mod name public? exp) + (step exp)) + + (( name exp) + (step exp)) + + (( name exp) + (step exp)) + + (( exps) + (for-each step exps)) + + (( vars meta body) + (hashq-set! parents x parent) + (hashq-set! bindings x + (let rev* ((vars vars) (out '())) + (cond ((null? vars) out) + ((pair? vars) (rev* (cdr vars) + (cons (car vars) out))) + (else (cons vars out))))) + (recur body x) + (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) + + (( vars vals exp) + (for-each step vals) + (hashq-set! bindings parent + (append (reverse vars) (hashq-ref bindings parent))) + (step exp)) + + (( vars vals exp) + (hashq-set! bindings parent + (append (reverse vars) (hashq-ref bindings parent))) + (for-each step vals) + (step exp)) + + (else #f))) + + (define (allocate-heap! binder) + (hashq-set! heap-indexes binder + (1+ (hashq-ref heap-indexes binder -1)))) + + (define (allocate! x level n) + (define (recur y) (allocate! y level n)) + (record-case x + (( proc args) + (apply max (recur proc) (map recur args))) + + (( test then else) + (max (recur test) (recur then) (recur else))) + + (( name gensym exp) + (recur exp)) + + (( mod name public? exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( exps) + (apply max (map recur exps))) + + (( vars meta body) + (let lp ((vars vars) (n 0)) + (if (null? vars) + (hashq-set! allocation x + (let ((nlocs (- (allocate! body (1+ level) n) n))) + (cons nlocs (1+ (hashq-ref heap-indexes x -1))))) + (let ((v (if (pair? vars) (car vars) vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap (1+ level) (allocate-heap! binder)) + (cons 'stack n)))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))))) + n) + + (( vars vals exp) + (let ((nmax (apply max (map recur vals)))) + (cond + ;; the `or' hack + ((and (conditional? exp) + (= (length vars) 1) + (let ((v (car vars))) + (and (not (hashq-ref heaps v)) + (= (hashq-ref refcounts v 0) 2) + (lexical-ref? (conditional-test exp)) + (eq? (lexical-ref-gensym (conditional-test exp)) v) + (lexical-ref? (conditional-then exp)) + (eq? (lexical-ref-gensym (conditional-then exp)) v)))) + (hashq-set! allocation (car vars) (cons 'stack n)) + ;; the 1+ for this var + (max nmax (1+ n) (allocate! (conditional-else exp) level n))) + (else + (let lp ((vars vars) (n n)) + (if (null? vars) + (max nmax (allocate! exp level n)) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n))) + (lp (cdr vars) (if binder n (1+ n))))))))))) + + (( vars vals exp) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x level n)) + vals)))) + (max nmax (allocate! exp level n))) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n))) + (lp (cdr vars) (if binder n (1+ n)))))))) + + (else n))) + + (define parents (make-hash-table)) + (define bindings (make-hash-table)) + (define heaps (make-hash-table)) + (define refcounts (make-hash-table)) + (define allocation (make-hash-table)) + (define heap-indexes (make-hash-table)) + + (analyze! x #f -1) + (allocate! x -1 0) + + allocation) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm new file mode 100644 index 000000000..94ace7e53 --- /dev/null +++ b/module/language/tree-il/compile-glil.scm @@ -0,0 +1,448 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il compile-glil) + #:use-module (system base syntax) + #:use-module (ice-9 receive) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (language tree-il optimize) + #:use-module (language tree-il analyze) + #:export (compile-glil)) + +;;; TODO: +;; +;; call-with-values -> mv-bind +;; basic degenerate-case reduction + +;; allocation: +;; sym -> (local . index) | (heap level . index) +;; lambda -> (nlocs . nexts) + +(define *comp-module* (make-fluid)) + +(define (compile-glil x e opts) + (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) + (x (optimize! x e opts)) + (allocation (analyze-lexicals x))) + (with-fluid* *comp-module* (or (and e (car e)) (current-module)) + (lambda () + (values (flatten-lambda x -1 allocation) + (and e (cons (car e) (cddr e))) + e))))) + + + +(define *primcall-ops* (make-hash-table)) +(for-each + (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x))) + '(((eq? . 2) . eq?) + ((eqv? . 2) . eqv?) + ((equal? . 2) . equal?) + ((= . 2) . ee?) + ((< . 2) . lt?) + ((> . 2) . gt?) + ((<= . 2) . le?) + ((>= . 2) . ge?) + ((+ . 2) . add) + ((- . 2) . sub) + ((* . 2) . mul) + ((/ . 2) . div) + ((quotient . 2) . quo) + ((remainder . 2) . rem) + ((modulo . 2) . mod) + ((not . 1) . not) + ((pair? . 1) . pair?) + ((cons . 2) . cons) + ((car . 1) . car) + ((cdr . 1) . cdr) + ((set-car! . 2) . set-car!) + ((set-cdr! . 2) . set-cdr!) + ((null? . 1) . null?) + ((list? . 1) . list?) + (list . list) + (vector . vector) + ((@slot-ref . 2) . slot-ref) + ((@slot-set! . 3) . slot-set))) + +(define (make-label) (gensym ":L")) + +(define (vars->bind-list ids vars allocation) + (map (lambda (id v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) (list id 'local (cdr loc))) + ((heap) (list id 'external (cddr loc))) + (else (error "badness" id v loc))))) + ids + vars)) + +(define (emit-bindings src ids vars allocation emit-code) + (if (pair? vars) + (emit-code src (make-glil-bind + (vars->bind-list ids vars allocation))))) + +(define (with-output-to-code proc) + (let ((out '())) + (define (emit-code src x) + (set! out (cons x out)) + (if src + (set! out (cons (make-glil-source src) out)))) + (proc emit-code) + (reverse out))) + +(define (flatten-lambda x level allocation) + (receive (ids vars nargs nrest) + (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) + (oids '()) (ovars '()) (n 0)) + (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) + ((pair? vars) (lp (cdr ids) (cdr vars) + (cons (car ids) oids) (cons (car vars) ovars) + (1+ n))) + (else (values (reverse (cons ids oids)) + (reverse (cons vars ovars)) + (1+ n) 1)))) + (let ((nlocs (car (hashq-ref allocation x))) + (nexts (cdr (hashq-ref allocation x)))) + (make-glil-program + nargs nrest nlocs nexts (lambda-meta x) + (with-output-to-code + (lambda (emit-code) + ;; write bindings and source debugging info + (emit-bindings #f ids vars allocation emit-code) + (if (lambda-src x) + (emit-code #f (make-glil-source (lambda-src x)))) + + ;; copy args to the heap if necessary + (let lp ((in vars) (n 0)) + (if (not (null? in)) + (let ((loc (hashq-ref allocation (car in)))) + (case (car loc) + ((heap) + (emit-code #f (make-glil-local 'ref n)) + (emit-code #f (make-glil-external 'set 0 (cddr loc))))) + (lp (cdr in) (1+ n))))) + + ;; and here, here, dear reader: we compile. + (flatten (lambda-body x) (1+ level) allocation emit-code))))))) + +(define (flatten x level allocation emit-code) + (define (emit-label label) + (emit-code #f (make-glil-label label))) + (define (emit-branch src inst label) + (emit-code src (make-glil-branch inst label))) + + (let comp ((x x) (context 'tail)) + (define (comp-tail tree) (comp tree context)) + (define (comp-push tree) (comp tree 'push)) + (define (comp-drop tree) (comp tree 'drop)) + + (record-case x + (() + (case context + ((push) (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src exp) + (case context + ((push) (emit-code src (make-glil-const exp))) + ((tail) + (emit-code src (make-glil-const exp)) + (emit-code #f (make-glil-call 'return 1))))) + + ;; FIXME: should represent sequence as exps tail + (( src exps) + (let lp ((exps exps)) + (if (null? (cdr exps)) + (comp-tail (car exps)) + (begin + (comp-drop (car exps)) + (lp (cdr exps)))))) + + (( src proc args) + ;; FIXME: need a better pattern-matcher here + (cond + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@apply) + (>= (length args) 1)) + (let ((proc (car args)) + (args (cdr args))) + (cond + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push))) + ;; tail: (lambda () (apply values '(1 2))) + ;; drop: (lambda () (apply values '(1 2)) 3) + ;; push: (lambda () (list (apply values '(10 12)) 1)) + (case context + ((drop) (for-each comp-drop args)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values* (length args)))))) + + (else + (case context + ((tail) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) + ((push) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'apply (1+ (length args))))) + ((drop) + ;; Well, shit. The proc might return any number of + ;; values (including 0), since it's in a drop context, + ;; yet apply does not create a MV continuation. So we + ;; mv-call out to our trampoline instead. + (comp-drop + (make-application src (make-primitive-ref #f 'apply) + (cons proc args))))))))) + + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push))) + ;; tail: (lambda () (values '(1 2))) + ;; drop: (lambda () (values '(1 2)) 3) + ;; push: (lambda () (list (values '(10 12)) 1)) + (case context + ((drop) (for-each comp-drop args)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values (length args)))))) + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2)) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label)) + (producer (car args)) (consumer (cadr args))) + (comp-push consumer) + (comp-push producer) + (emit-code src (make-glil-mv-call 0 MV)) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args 1))) + (else (emit-code src (make-glil-call 'call 1)) + (emit-branch #f 'br POST))) + (emit-label MV) + (case context + ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) + (else (emit-code src (make-glil-call 'call/nargs 0)) + (emit-label POST) + (if (eq? context 'drop) + (emit-code #f (make-glil-call 'drop 1))))))) + + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-current-continuation) + (= (length args) 1)) + (case context + ((tail) + (comp-push (car args)) + (emit-code src (make-glil-call 'goto/cc 1))) + ((push) + (comp-push (car args)) + (emit-code src (make-glil-call 'call/cc 1))) + ((drop) + ;; Crap. Just like `apply' in drop context. + (comp-drop + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args))))) + + ((and (primitive-ref? proc) + (or (hash-ref *primcall-ops* + (cons (primitive-ref-name proc) (length args))) + (hash-ref *primcall-ops* (primitive-ref-name proc)))) + => (lambda (op) + (for-each comp-push args) + (emit-code src (make-glil-call op (length args))) + (case context + ((tail) (emit-code #f (make-glil-call 'return 1))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))))) + (else + (comp-push proc) + (for-each comp-push args) + (let ((len (length args))) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args len))) + ((push) (emit-code src (make-glil-call 'call len))) + ((drop) + (let ((MV (make-label)) (POST (make-label))) + (emit-code src (make-glil-mv-call len MV)) + (emit-code #f (make-glil-call 'drop 1)) + (emit-branch #f 'br POST) + (emit-label MV) + (emit-code #f (make-glil-mv-bind '() #f)) + (emit-code #f (make-glil-unbind)) + (emit-label POST)))))))) + + (( src test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (br L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (emit-branch src 'br-if-not L1) + (comp-tail then) + (if (not (eq? context 'tail)) + (emit-branch #f 'br L2)) + (emit-label L1) + (comp-tail else) + (if (not (eq? context 'tail)) + (emit-label L2)))) + + (( src name) + (cond + ((eq? (module-variable (fluid-ref *comp-module*) name) + (module-variable the-root-module name)) + (case context + ((push) + (emit-code src (make-glil-toplevel 'ref name))) + ((tail) + (emit-code src (make-glil-toplevel 'ref name)) + (emit-code #f (make-glil-call 'return 1))))) + (else + (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) + (case context + ((push) + (emit-code src (make-glil-module 'ref '(guile) name #f))) + ((tail) + (emit-code src (make-glil-module 'ref '(guile) name #f)) + (emit-code #f (make-glil-call 'return 1))))))) + + (( src name gensym) + (case context + ((push tail) + (let ((loc (hashq-ref allocation gensym))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'ref (cdr loc)))) + ((heap) + (emit-code src (make-glil-external + 'ref (- level (cadr loc)) (cddr loc)))) + (else (error "badness" x loc))) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))))) + + (( src name gensym exp) + (comp-push exp) + (let ((loc (hashq-ref allocation gensym))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external + 'set (- level (cadr loc)) (cddr loc)))) + (else (error "badness" x loc)))) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src mod name public?) + (emit-code src (make-glil-module 'ref mod name public?)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1))) + ((tail) (emit-code #f (make-glil-call 'return 1))))) + + (( src mod name public? exp) + (comp-push exp) + (emit-code src (make-glil-module 'set mod name public?)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src name) + (emit-code src (make-glil-toplevel 'ref name)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1))) + ((tail) (emit-code #f (make-glil-call 'return 1))))) + + (( src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'set name)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'define name)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (() + (case context + ((push) + (emit-code #f (flatten-lambda x level allocation))) + ((tail) + (emit-code #f (flatten-lambda x level allocation)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src names vars vals exp) + (for-each comp-push vals) + (emit-bindings src names vars allocation emit-code) + (for-each (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external 'set 0 (cddr loc)))) + (else (error "badness" x loc))))) + (reverse vars)) + (comp-tail exp) + (emit-code #f (make-glil-unbind))) + + (( src names vars vals exp) + (for-each comp-push vals) + (emit-bindings src names vars allocation emit-code) + (for-each (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external 'set 0 (cddr loc)))) + (else (error "badness" x loc))))) + (reverse vars)) + (comp-tail exp) + (emit-code #f (make-glil-unbind)))))) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm new file mode 100644 index 000000000..3a02e021e --- /dev/null +++ b/module/language/tree-il/optimize.scm @@ -0,0 +1,42 @@ +;;; Tree-il optimizer + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il optimize) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:export (optimize!)) + +(define (env-module e) + (if e (car e) (current-module))) + +(define (optimize! x env opts) + (expand-primitives! (resolve-primitives! x (env-module env)))) + +;; Possible optimizations: +;; * constant folding, propagation +;; * procedure inlining +;; * always when single call site +;; * always for "trivial" procs +;; * otherwise who knows +;; * dead code elimination +;; * degenerate case optimizations +;; * "fixing letrec" + diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm new file mode 100644 index 000000000..51bbfeae9 --- /dev/null +++ b/module/language/tree-il/primitives.scm @@ -0,0 +1,206 @@ +;;; GHIL macros + +;; Copyright (C) 2001 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 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il primitives) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:use-module (srfi srfi-16) + #:export (resolve-primitives! add-interesting-primitive! + expand-primitives!)) + +(define *interesting-primitive-names* + '(apply @apply + call-with-values @call-with-values + call-with-current-continuation @call-with-current-continuation + call/cc + values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + + list vector + + car cdr + set-car! set-cdr! + + caar cadr cdar cddr + + caaar caadr cadar caddr cdaar cdadr cddar cdddr + + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) + +(define (add-interesting-primitive! name) + (hashq-set! *interesting-primitive-vars* + (module-variable (current-module) name) name)) + +(define *interesting-primitive-vars* (make-hash-table)) + +(for-each add-interesting-primitive! *interesting-primitive-names*) + +(define (resolve-primitives! x mod) + (post-order! + (lambda (x) + (record-case x + (( src name) + (and (hashq-ref *interesting-primitive-vars* + (module-variable mod name)) + (make-primitive-ref src name))) + (( src mod name public?) + ;; for the moment, we're disabling primitive resolution for + ;; public refs because resolve-interface can raise errors. + (let ((m (and (not public?) (resolve-module mod)))) + (and m (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (make-primitive-ref src name)))) + (else #f))) + x)) + + + +(define *primitive-expand-table* (make-hash-table)) + +(define (expand-primitives! x) + (pre-order! + (lambda (x) + (record-case x + (( src proc args) + (and (primitive-ref? proc) + (let ((expand (hashq-ref *primitive-expand-table* + (primitive-ref-name proc)))) + (and expand (apply expand src args))))) + (else #f))) + x)) + +;;; I actually did spend about 10 minutes trying to redo this with +;;; syntax-rules. Patches appreciated. +;;; +(define-macro (define-primitive-expander sym . clauses) + (define (inline-args args) + (let lp ((in args) (out '())) + (cond ((null? in) `(list ,@(reverse out))) + ((symbol? in) `(cons* ,@(reverse out) ,in)) + ((pair? (car in)) + (lp (cdr in) + (cons `(make-application src (make-primitive-ref src ',(caar in)) + ,(inline-args (cdar in))) + out))) + ((symbol? (car in)) + ;; assume it's locally bound + (lp (cdr in) (cons (car in) out))) + ((number? (car in)) + (lp (cdr in) (cons `(make-const src ,(car in)) out))) + (else + (error "what what" (car in)))))) + (define (consequent exp) + (cond + ((pair? exp) + `(make-application src (make-primitive-ref src ',(car exp)) + ,(inline-args (cdr exp)))) + ((symbol? exp) + ;; assume locally bound + exp) + ((number? exp) + `(make-const src ,exp)) + (else (error "bad consequent yall" exp)))) + `(hashq-set! *primitive-expand-table* + ',sym + (case-lambda + ,@(let lp ((in clauses) (out '())) + (if (null? in) + (reverse (cons '(else #f) out)) + (lp (cddr in) + (cons `((src . ,(car in)) + ,(consequent (cadr in))) out))))))) + +(define-primitive-expander + + () 0 + (x) x + (x y z . rest) (+ x (+ y z . rest))) + +(define-primitive-expander * + () 1 + (x) x + (x y z . rest) (* x (* y z . rest))) + +(define-primitive-expander - + (x) (- 0 x) + (x y z . rest) (- x (+ y z . rest))) + +(define-primitive-expander 1- + (x) (- x 1)) + +(define-primitive-expander / + (x) (/ 1 x) + (x y z . rest) (/ x (* y z . rest))) + +(define-primitive-expander caar (x) (car (car x))) +(define-primitive-expander cadr (x) (car (cdr x))) +(define-primitive-expander cdar (x) (cdr (car x))) +(define-primitive-expander cddr (x) (cdr (cdr x))) +(define-primitive-expander caaar (x) (car (car (car x)))) +(define-primitive-expander caadr (x) (car (car (cdr x)))) +(define-primitive-expander cadar (x) (car (cdr (car x)))) +(define-primitive-expander caddr (x) (car (cdr (cdr x)))) +(define-primitive-expander cdaar (x) (cdr (car (car x)))) +(define-primitive-expander cdadr (x) (cdr (car (cdr x)))) +(define-primitive-expander cddar (x) (cdr (cdr (car x)))) +(define-primitive-expander cdddr (x) (cdr (cdr (cdr x)))) +(define-primitive-expander caaaar (x) (car (car (car (car x))))) +(define-primitive-expander caaadr (x) (car (car (car (cdr x))))) +(define-primitive-expander caadar (x) (car (car (cdr (car x))))) +(define-primitive-expander caaddr (x) (car (car (cdr (cdr x))))) +(define-primitive-expander cadaar (x) (car (cdr (car (car x))))) +(define-primitive-expander cadadr (x) (car (cdr (car (cdr x))))) +(define-primitive-expander caddar (x) (car (cdr (cdr (car x))))) +(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x))))) +(define-primitive-expander cdaaar (x) (cdr (car (car (car x))))) +(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x))))) +(define-primitive-expander cdadar (x) (cdr (car (cdr (car x))))) +(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x))))) +(define-primitive-expander cddaar (x) (cdr (cdr (car (car x))))) +(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x))))) +(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x))))) +(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) + +(define-primitive-expander cons* + (x) x + (x y) (cons x y) + (x y . rest) (cons x (cons* y . rest))) + +(define-primitive-expander acons (x y z) + (cons (cons x y) z)) + +(define-primitive-expander apply (f . args) + (@apply f . args)) + +(define-primitive-expander call-with-values (producer consumer) + (@call-with-values producer consumer)) + +(define-primitive-expander call-with-current-continuation (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander call/cc (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander values (x) x) diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm new file mode 100644 index 000000000..c1f098230 --- /dev/null +++ b/module/language/tree-il/spec.scm @@ -0,0 +1,43 @@ +;;; Tree Intermediate Language + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il spec) + #:use-module (system base language) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (language tree-il compile-glil) + #:export (tree-il)) + +(define (write-tree-il exp . port) + (apply write (unparse-tree-il exp) port)) + +(define (join exps env) + (make-sequence #f exps)) + +(define-language tree-il + #:title "Tree Intermediate Language" + #:version "1.0" + #:reader read + #:printer write-tree-il + #:parser parse-tree-il + #:joiner join + #:compilers `((glil . ,compile-glil)) + ) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 2254f93e5..6e3b15009 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -154,17 +154,6 @@ ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) ;;; OPTION ::= KEYWORD VALUE ;;; -(define (define-class-pre-definition kw val) - (case kw - ((#:getter #:setter) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-generic ,val))) - ((#:accessor) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-accessor ,val))) - (else #f))) (define (kw-do-map mapper f kwargs) (define (keywords l) @@ -180,69 +169,6 @@ (a (args kwargs))) (mapper f k a))) -;;; This code should be implemented in C. -;;; -(define-macro (define-class name supers . slots) - ;; Some slot options require extra definitions to be made. In - ;; particular, we want to make sure that the generic function objects - ;; which represent accessors exist before `make-class' tries to add - ;; methods to them. - ;; - ;; Postpone some error handling to class macro. - ;; - `(begin - ;; define accessors - ,@(append-map (lambda (slot) - (kw-do-map filter-map - define-class-pre-definition - (if (pair? slot) (cdr slot) '()))) - (take-while (lambda (x) (not (keyword? x))) slots)) - (if (and (defined? ',name) - (is-a? ,name ) - (memq (class-precedence-list ,name))) - (class-redefinition ,name - (class ,supers ,@slots #:name ',name)) - (define ,name (class ,supers ,@slots #:name ',name))))) - -(define standard-define-class define-class) - -;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) -;;; -;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) -;;; OPTION ::= KEYWORD VALUE -;;; -(define-macro (class supers . slots) - (define (make-slot-definition-forms slots) - (map - (lambda (def) - (cond - ((pair? def) - `(list ',(car def) - ,@(kw-do-map append-map - (lambda (kw arg) - (case kw - ((#:init-form) - `(#:init-form ',arg - #:init-thunk (lambda () ,arg))) - (else (list kw arg)))) - (cdr def)))) - (else - `(list ',def)))) - slots)) - - (if (not (list? supers)) - (goops-error "malformed superclass list: ~S" supers)) - (let ((slot-defs (cons #f '())) - (slots (take-while (lambda (x) (not (keyword? x))) slots)) - (options (or (find-tail keyword? slots) '()))) - `(make-class - ;; evaluate super class variables - (list ,@supers) - ;; evaluate slot definitions, except the slot name! - (list ,@(make-slot-definition-forms slots)) - ;; evaluate class options - ,@options))) - (define (make-class supers slots . options) (let ((env (or (get-keyword #:environment options #f) (top-level-env)))) @@ -275,6 +201,108 @@ #:environment env options)))) +;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; +(define-macro (class supers . slots) + (define (make-slot-definition-forms slots) + (map + (lambda (def) + (cond + ((pair? def) + `(list ',(car def) + ,@(kw-do-map append-map + (lambda (kw arg) + (case kw + ((#:init-form) + `(#:init-form ',arg + #:init-thunk (lambda () ,arg))) + (else (list kw arg)))) + (cdr def)))) + (else + `(list ',def)))) + slots)) + (if (not (list? supers)) + (goops-error "malformed superclass list: ~S" supers)) + (let ((slot-defs (cons #f '())) + (slots (take-while (lambda (x) (not (keyword? x))) slots)) + (options (or (find-tail keyword? slots) '()))) + `(make-class + ;; evaluate super class variables + (list ,@supers) + ;; evaluate slot definitions, except the slot name! + (list ,@(make-slot-definition-forms slots)) + ;; evaluate class options + ,@options))) + +(define-syntax define-class-pre-definition + (lambda (x) + (syntax-case x () + ((_ (k arg rest ...) out ...) + (keyword? (syntax->datum (syntax k))) + (case (syntax->datum (syntax k)) + ((#:getter #:setter) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))) + ((#:accessor) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))) + (else + (syntax + (define-class-pre-definition (rest ...) out ...))))) + ((_ () out ...) + (syntax (begin out ...)))))) + +;; Some slot options require extra definitions to be made. In +;; particular, we want to make sure that the generic function objects +;; which represent accessors exist before `make-class' tries to add +;; methods to them. +(define-syntax define-class-pre-definitions + (lambda (x) + (syntax-case x () + ((_ () out ...) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (keyword? (syntax->datum (syntax slot))) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (identifier? (syntax slot)) + (syntax (define-class-pre-definitions (rest ...) + out ...))) + ((_ ((slotname slotopt ...) rest ...) out ...) + (syntax (define-class-pre-definitions (rest ...) + out ... (define-class-pre-definition (slotopt ...)))))))) + +(define-syntax define-class + (syntax-rules () + ((_ name supers slot ...) + (begin + (define-class-pre-definitions (slot ...)) + (if (and (defined? 'name) + (is-a? name ) + (memq (class-precedence-list name))) + (class-redefinition name + (class supers slot ... #:name 'name)) + (toplevel-define! 'name (class supers slot ... #:name 'name))))))) + +(define-syntax standard-define-class + (syntax-rules () + ((_ arg ...) (define-class arg ...)))) + ;;; ;;; {Generic functions and accessors} ;;; @@ -363,13 +391,13 @@ (else (make #:name name))))) ;; same semantics as -(define-macro (define-accessor name) - (if (not (symbol? name)) - (goops-error "bad accessor name: ~S" name)) - `(define ,name - (if (and (defined? ',name) (is-a? ,name )) - (make #:name ',name) - (ensure-accessor (if (defined? ',name) ,name #f) ',name)))) +(define-syntax define-accessor + (syntax-rules () + ((_ name) + (define name + (cond ((not (defined? 'name)) (ensure-accessor #f 'name)) + ((is-a? name ) (make #:name 'name)) + (else (ensure-accessor name 'name))))))) (define (make-setter-name name) (string->symbol (string-append "setter:" (symbol->string name)))) @@ -424,78 +452,132 @@ ;;; {Methods} ;;; -(define-macro (define-method head . body) - (if (not (pair? head)) - (goops-error "bad method head: ~S" head)) - (let ((gf (car head))) - (cond ((and (pair? gf) - (eq? (car gf) 'setter) - (pair? (cdr gf)) - (symbol? (cadr gf)) - (null? (cddr gf))) - ;; named setter method - (let ((name (cadr gf))) - (cond ((not (symbol? name)) - `(add-method! (setter ,name) - (method ,(cdr head) ,@body))) - (else - `(begin - (if (or (not (defined? ',name)) - (not (is-a? ,name ))) - (define-accessor ,name)) - (add-method! (setter ,name) - (method ,(cdr head) ,@body))))))) - ((not (symbol? gf)) - `(add-method! ,gf (method ,(cdr head) ,@body))) - (else - `(begin - ;; FIXME: this code is how it always was, but it's quite - ;; cracky: it will only define the generic function if it - ;; was undefined before (ok), or *was defined to #f*. The - ;; latter is crack. But there are bootstrap issues about - ;; fixing this -- change it to (is-a? ,gf ) and - ;; see. - (if (or (not (defined? ',gf)) - (not ,gf)) - (define-generic ,gf)) - (add-method! ,gf - (method ,(cdr head) ,@body))))))) +(define (toplevel-define! name val) + (module-define! (current-module) name val)) -(define-macro (method args . body) - (letrec ((specializers - (lambda (ls) - (cond ((null? ls) (list (list 'quote '()))) - ((pair? ls) (cons (if (pair? (car ls)) - (cadar ls) - ') - (specializers (cdr ls)))) - (else '())))) - (formals - (lambda (ls) - (if (pair? ls) - (cons (if (pair? (car ls)) (caar ls) (car ls)) - (formals (cdr ls))) - ls)))) - (let ((make-proc (compile-make-procedure (formals args) - (specializers args) - body))) - `(make - #:specializers (cons* ,@(specializers args)) - #:formals ',(formals args) - #:body ',body - #:make-procedure ,make-proc - #:procedure ,(and (not make-proc) - ;; that is to say: we set #:procedure if - ;; `compile-make-procedure' returned `#f', - ;; which is the case if `body' does not - ;; contain a call to `next-method' - `(lambda ,(formals args) - ,@(if (null? body) - ;; This used to be '((begin)), but - ;; guile's memoizer doesn't like - ;; (lambda args (begin)). - '((if #f #f)) - body))))))) +(define-syntax define-method + (syntax-rules (setter) + ((_ ((setter name) . args) body ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name ))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method args body ...)))) + ((_ (name . args) body ...) + (begin + ;; FIXME: this code is how it always was, but it's quite cracky: + ;; it will only define the generic function if it was undefined + ;; before (ok), or *was defined to #f*. The latter is crack. But + ;; there are bootstrap issues about fixing this -- change it to + ;; (is-a? name ) and see. + (if (or (not (defined? 'name)) + (not name)) + (toplevel-define! 'name (make #:name 'name))) + (add-method! name (method args body ...)))))) + +(define-syntax method + (lambda (x) + (define (parse-args args) + (let lp ((ls args) (formals '()) (specializers '())) + (syntax-case ls () + (((f s) . rest) + (and (identifier? (syntax f)) (identifier? (syntax s))) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax s) specializers))) + ((f . rest) + (identifier? (syntax f)) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax ) specializers))) + (() + (list (reverse formals) + (reverse (cons (syntax '()) specializers)))) + (tail + (identifier? (syntax tail)) + (list (append (reverse formals) (syntax tail)) + (reverse (cons (syntax ) specializers))))))) + + (define (find-free-id exp referent) + (syntax-case exp () + ((x . y) + (or (find-free-id (syntax x) referent) + (find-free-id (syntax y) referent))) + (x + (identifier? (syntax x)) + (let ((id (datum->syntax (syntax x) referent))) + (and (free-identifier=? (syntax x) id) id))) + (_ #f))) + + (define (compute-procedure formals body) + (syntax-case body () + ((body0 ...) + (with-syntax ((formals formals)) + (syntax (lambda formals body0 ...)))))) + + (define (->proper args) + (let lp ((ls args) (out '())) + (syntax-case ls () + ((x . xs) (lp (syntax xs) (cons (syntax x) out))) + (() (reverse out)) + (tail (reverse (cons (syntax tail) out)))))) + + (define (compute-make-procedure formals body next-method) + (syntax-case body () + ((body ...) + (with-syntax ((next-method next-method)) + (syntax-case formals () + ((formal ...) + (syntax + (lambda (real-next-method) + (lambda (formal ...) + (let ((next-method (lambda args + (if (null? args) + (real-next-method formal ...) + (apply real-next-method args))))) + body ...))))) + (formals + (with-syntax (((formal ...) (->proper (syntax formals)))) + (syntax + (lambda (real-next-method) + (lambda formals + (let ((next-method (lambda args + (if (null? args) + (apply real-next-method formal ...) + (apply real-next-method args))))) + body ...))))))))))) + + (define (compute-procedures formals body) + ;; So, our use of this is broken, because it operates on the + ;; pre-expansion source code. It's equivalent to just searching + ;; for referent in the datums. Ah well. + (let ((id (find-free-id body 'next-method))) + (if id + ;; return a make-procedure + (values (syntax #f) + (compute-make-procedure formals body id)) + (values (compute-procedure formals body) + (syntax #f))))) + + (syntax-case x () + ((_ args) (syntax (method args (if #f #f)))) + ((_ args body0 body1 ...) + (with-syntax (((formals (specializer ...)) (parse-args (syntax args)))) + (call-with-values + (lambda () + (compute-procedures (syntax formals) (syntax (body0 body1 ...)))) + (lambda (procedure make-procedure) + (with-syntax ((procedure procedure) + (make-procedure make-procedure)) + (syntax + (make + #:specializers (cons* specializer ...) + #:formals 'formals + #:body '(body0 body1 ...) + #:make-procedure make-procedure + #:procedure procedure)))))))))) ;;; ;;; {add-method!} @@ -1046,27 +1128,9 @@ ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. (eval-when (compile) - (use-modules ((language scheme compile-ghil) :select (define-scheme-translator)) - ((language ghil) :select (make-ghil-inline make-ghil-call)) - (system base pmatch)) - - ;; unfortunately, can't use define-inline because these are primitive - ;; syntaxen. - (define-scheme-translator @slot-ref - ((,obj ,index) (guard (integer? index) - (>= index 0) (< index max-fixnum)) - (make-ghil-inline #f #f 'slot-ref - (list (retrans obj) (retrans index)))) - (else - (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))) - - (define-scheme-translator @slot-set! - ((,obj ,index ,val) (guard (integer? index) - (>= index 0) (< index max-fixnum)) - (make-ghil-inline #f #f 'slot-set - (list (retrans obj) (retrans index) (retrans val)))) - (else - (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))) + (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) + (add-interesting-primitive! '@slot-ref) + (add-interesting-primitive! '@slot-set!)) (eval-when (eval load compile) (define num-standard-pre-cache 20)) diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm index 3962be4bc..e6b13c416 100644 --- a/module/oop/goops/compile.scm +++ b/module/oop/goops/compile.scm @@ -24,7 +24,7 @@ (define-module (oop goops compile) :use-module (oop goops) :use-module (oop goops util) - :export (compute-cmethod compile-make-procedure) + :export (compute-cmethod) :no-backtrace ) @@ -60,9 +60,7 @@ ;;; So, for the reader: there basic idea is that, given that the ;;; semantics of `next-method' depend on the concrete types being ;;; dispatched, why not compile a specific procedure to handle each type -;;; combination that we see at runtime. There are two compilation -;;; strategies implemented: one for the memoizer, and one for the VM -;;; compiler. +;;; combination that we see at runtime. ;;; ;;; In theory we can do much better than a bytecode compilation, because ;;; we know the *exact* types of the arguments. It's ideal for native @@ -71,32 +69,6 @@ ;;; I think this whole generic application mess would benefit from a ;;; strict MOP. -;;; Temporary solution---return #f if x doesn't refer to `next-method'. -(define (next-method? x) - (and (pair? x) - (or (eq? (car x) 'next-method) - (next-method? (car x)) - (next-method? (cdr x))))) - -;; Called by the `method' macro in goops.scm. -(define (compile-make-procedure formals specializers body) - (and (next-method? body) - (let ((next-method-sym (gensym " next-method")) - (args-sym (gensym))) - `(lambda (,next-method-sym) - (lambda ,formals - (let ((next-method (lambda ,args-sym - (if (null? ,args-sym) - ,(if (list? formals) - `(,next-method-sym ,@formals) - `(apply - ,next-method-sym - ,@(improper->proper formals))) - (apply ,next-method-sym ,args-sym))))) - ,@(if (null? body) - '((begin)) - body))))))) - (define (compile-method methods types) (let ((make-procedure (slot-ref (car methods) 'make-procedure))) (if make-procedure diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index a54044729..ed9f3077e 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -209,9 +209,8 @@ ;;; ;; Backward compatibility -(if (not (defined? 'lookup-create-cmethod)) - (define (lookup-create-cmethod gf args) - (no-applicable-method (car args) (cadr args)))) +(define (lookup-create-cmethod gf args) + (no-applicable-method (car args) (cadr args))) (define (memoize-method! gf args exp) (if (not (slot-ref gf 'used-by)) diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm index 4d64da8bb..2aedd7698 100644 --- a/module/oop/goops/save.scm +++ b/module/oop/goops/save.scm @@ -110,9 +110,7 @@ ;;; Readables ;;; -(if (or (not (defined? 'readables)) - (not readables)) - (define readables (make-weak-key-hash-table 61))) +(define readables (make-weak-key-hash-table 61)) (define-macro (readable exp) `(make-readable ,exp ',(copy-tree exp))) diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm index 48e76f312..c0cb76fbb 100644 --- a/module/oop/goops/simple.scm +++ b/module/oop/goops/simple.scm @@ -23,6 +23,9 @@ :export (define-class) :no-backtrace) -(define define-class define-class-with-accessors-keywords) +(define-syntax define-class + (syntax-rules () + ((_ arg ...) + (define-class-with-accessors-keywords arg ...)))) (module-use! %module-public-interface (resolve-interface '(oop goops))) diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm index 60ab293c3..ef943cf96 100644 --- a/module/oop/goops/stklos.scm +++ b/module/oop/goops/stklos.scm @@ -47,51 +47,30 @@ ;;; Enable keyword support (*fixme*---currently this has global effect) (read-set! keywords 'prefix) -(define standard-define-class-transformer - (macro-transformer standard-define-class)) +(define-syntax define-class + (syntax-rules () + ((_ name supers (slot ...) rest ...) + (standard-define-class name supers slot ... rest ...)))) -(define define-class - ;; Syntax - (let ((name cadr) - (supers caddr) - (slots cadddr) - (rest cddddr)) - (procedure->memoizing-macro - (lambda (exp env) - (standard-define-class-transformer - `(define-class ,(name exp) ,(supers exp) ,@(slots exp) - ,@(rest exp)) - env))))) +(define (toplevel-define! name val) + (module-define! (current-module) name val)) -(define define-method - (procedure->memoizing-macro - (lambda (exp env) - (let ((name (cadr exp))) - (if (and (pair? name) - (eq? (car name) 'setter) - (pair? (cdr name)) - (null? (cddr name))) - (let ((name (cadr name))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - (if (not (is-a? ,name )) - (define-accessor ,name)) - (add-method! (setter ,name) (method ,@(cddr exp))))) - (else - `(begin - (define-accessor ,name) - (add-method! (setter ,name) (method ,@(cddr exp))))))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - (if (not (or (is-a? ,name ) - (is-a? ,name ))) - (define-generic ,name)) - (add-method! ,name (method ,@(cddr exp))))) - (else - `(begin - (define-generic ,name) - (add-method! ,name (method ,@(cddr exp))))))))))) +(define-syntax define-method + (syntax-rules (setter) + ((_ (setter name) rest ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name ))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method rest ...)))) + ((_ name rest ...) + (begin + (if (or (not (defined? 'name)) + (not (or (is-a? name ) + (is-a? name )))) + (toplevel-define! 'name + (ensure-generic + (if (defined? 'name) name #f) 'name))) + (add-method! name (method rest ...)))))) diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm new file mode 100644 index 000000000..793cbc020 --- /dev/null +++ b/module/rnrs/bytevector.scm @@ -0,0 +1,84 @@ +;;;; bytevector.scm --- R6RS bytevector API + +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 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 + +;;; Author: Ludovic Courtès + +;;; Commentary: +;;; +;;; A "bytevector" is a raw bit string. This module provides 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 decode binary data. +;;; +;;; Code: + +(define-module (rnrs bytevector) + :export-syntax (endianness) + :export (native-endianness bytevector? + make-bytevector bytevector-length bytevector=? bytevector-fill! + bytevector-copy! bytevector-copy bytevector-u8-ref + bytevector-s8-ref + bytevector-u8-set! bytevector-s8-set! bytevector->u8-list + u8-list->bytevector + bytevector-uint-ref bytevector-uint-set! + bytevector-sint-ref bytevector-sint-set! + bytevector->sint-list bytevector->uint-list + uint-list->bytevector sint-list->bytevector + + bytevector-u16-ref bytevector-s16-ref + bytevector-u16-set! bytevector-s16-set! + bytevector-u16-native-ref bytevector-s16-native-ref + bytevector-u16-native-set! bytevector-s16-native-set! + + bytevector-u32-ref bytevector-s32-ref + bytevector-u32-set! bytevector-s32-set! + bytevector-u32-native-ref bytevector-s32-native-ref + bytevector-u32-native-set! bytevector-s32-native-set! + + bytevector-u64-ref bytevector-s64-ref + bytevector-u64-set! bytevector-s64-set! + bytevector-u64-native-ref bytevector-s64-native-ref + bytevector-u64-native-set! bytevector-s64-native-set! + + bytevector-ieee-single-ref + bytevector-ieee-single-set! + bytevector-ieee-single-native-ref + bytevector-ieee-single-native-set! + + bytevector-ieee-double-ref + bytevector-ieee-double-set! + bytevector-ieee-double-native-ref + bytevector-ieee-double-native-set! + + string->utf8 string->utf16 string->utf32 + utf8->string utf16->string utf32->string)) + + +(load-extension "libguile" "scm_init_bytevectors") + +(define-macro (endianness sym) + (if (memq sym '(big little)) + `(quote ,sym) + (error "unsupported endianness" sym))) + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; bytevector.scm ends here diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm new file mode 100644 index 000000000..73843ee55 --- /dev/null +++ b/module/rnrs/io/ports.scm @@ -0,0 +1,111 @@ +;;;; ports.scm --- R6RS port API + +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 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 + +;;; Author: Ludovic Courtès + +;;; Commentary: +;;; +;;; The I/O port API of the R6RS is provided by this module. In many areas +;;; it complements or refines Guile's own historical port API. For instance, +;;; it allows for binary I/O with bytevectors. +;;; +;;; Code: + +(define-module (rnrs io ports) + :re-export (eof-object? port? input-port? output-port?) + :export (eof-object + + ;; input & output ports + port-transcoder binary-port? transcoded-port + port-position set-port-position! + port-has-port-position? port-has-set-port-position!? + call-with-port + + ;; input ports + open-bytevector-input-port + make-custom-binary-input-port + + ;; binary input + get-u8 lookahead-u8 + get-bytevector-n get-bytevector-n! + get-bytevector-some get-bytevector-all + + ;; output ports + open-bytevector-output-port + make-custom-binary-output-port + + ;; binary output + put-u8 put-bytevector)) + +(load-extension "libguile" "scm_init_r6rs_ports") + + + +;;; +;;; Input and output ports. +;;; + +(define (port-transcoder port) + (error "port transcoders are not supported" port)) + +(define (binary-port? port) + ;; So far, we don't support transcoders other than the binary transcoder. + #t) + +(define (transcoded-port port) + (error "port transcoders are not supported" port)) + +(define (port-position port) + "Return the offset (an integer) indicating where the next octet will be +read from/written to in @var{port}." + + ;; FIXME: We should raise an `&assertion' error when not supported. + (seek port 0 SEEK_CUR)) + +(define (set-port-position! port offset) + "Set the position where the next octet will be read from/written to +@var{port}." + + ;; FIXME: We should raise an `&assertion' error when not supported. + (seek port offset SEEK_SET)) + +(define (port-has-port-position? port) + "Return @code{#t} is @var{port} supports @code{port-position}." + (and (false-if-exception (port-position port)) #t)) + +(define (port-has-set-port-position!? port) + "Return @code{#t} is @var{port} supports @code{set-port-position!}." + (and (false-if-exception (set-port-position! port (port-position port))) + #t)) + +(define (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}." + (dynamic-wind + (lambda () + #t) + (lambda () + (proc port)) + (lambda () + (close-port port)))) + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; ports.scm ends here diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm index 9e17d6632..afa1730f1 100644 --- a/module/srfi/srfi-11.scm +++ b/module/srfi/srfi-11.scm @@ -37,7 +37,6 @@ ;;; Code: (define-module (srfi srfi-11) - :use-module (ice-9 syncase) :export-syntax (let-values let*-values)) (cond-expand-provide (current-module) '(srfi-11)) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 925ecb304..dd92079be 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -151,8 +151,10 @@ (hashq-set! thread-exception-handlers ct hl) (handler obj)) (lambda () - (let ((r (thunk))) - (hashq-set! thread-exception-handlers ct hl) r)))))) + (call-with-values thunk + (lambda res + (hashq-set! thread-exception-handlers ct hl) + (apply values res)))))))) (define (current-exception-handler) (car (current-handler-stack))) @@ -249,8 +251,8 @@ (define (wrap thunk) (lambda (continuation) (with-exception-handler (lambda (obj) - (apply (current-exception-handler) (list obj)) - (apply continuation (list))) + ((current-exception-handler) obj) + (continuation)) thunk))) ;; A pass-thru to cancel-thread that first installs a handler that throws diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm index 086751170..87154d6df 100644 --- a/module/srfi/srfi-39.scm +++ b/module/srfi/srfi-39.scm @@ -35,7 +35,6 @@ ;;; Code: (define-module (srfi srfi-39) - #:use-module (ice-9 syncase) #:use-module (srfi srfi-16) #:export (make-parameter) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 7d54947e3..f6522f735 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -29,7 +29,7 @@ #:export (syntax-error *current-language* compiled-file-name compile-file compile-and-load - compile compile-time-environment + compile decompile) #:export-syntax (call-with-compile-error-catch)) @@ -107,9 +107,9 @@ port))) comp)) -(define* (compile-and-load file #:key (to 'value) (opts '())) - (read-and-compile (open-input-port file) - #:from lang #:to to #:opts opts)) +(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '())) + (read-and-compile (open-input-file file) + #:from from #:to to #:opts opts)) (define (compiled-file-name file) (let ((base (basename file)) @@ -135,11 +135,6 @@ ;;; Compiler interface ;;; -(define (read-file-in file lang) - (call-with-input-file file - (or (language-read-file lang) - (error "language has no #:read-file" lang)))) - (define (compile-passes from to opts) (map cdr (or (lookup-compilation-order from to) @@ -152,13 +147,6 @@ (receive (x e new-cenv) ((car passes) x e opts) (lp (cdr passes) x e (if first? new-cenv cenv) #f))))) -(define (compile-time-environment) - "A special function known to the compiler that, when compiled, will -return a representation of the lexical environment in place at compile -time. Useful for supporting some forms of dynamic compilation. Returns -#f if called from the interpreter." - #f) - (define (find-language-joint from to) (let lp ((in (reverse (or (lookup-compilation-order from to) (error "no way to compile" from "to" to)))) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 649137c4d..8ae4d9667 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -23,7 +23,7 @@ #:use-module (system base syntax) #:export (define-language language? lookup-language make-language language-name language-title language-version language-reader - language-printer language-parser language-read-file + language-printer language-parser language-compilers language-decompilers language-evaluator language-joiner @@ -42,7 +42,6 @@ reader printer (parser #f) - (read-file #f) (compilers '()) (decompilers '()) (evaluator #f) diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm index 902fc49a5..4777431e5 100644 --- a/module/system/base/pmatch.scm +++ b/module/system/base/pmatch.scm @@ -1,5 +1,4 @@ (define-module (system base pmatch) - #:use-module (ice-9 syncase) #:export (pmatch)) ;; FIXME: shouldn't have to export ppat... @@ -17,15 +16,15 @@ (let ((v (op arg ...))) (pmatch v cs ...))) ((_ v) (if #f #f)) - ((_ v (else e0 e ...)) (begin e0 e ...)) + ((_ v (else e0 e ...)) (let () e0 e ...)) ((_ v (pat (guard g ...) e0 e ...) cs ...) (let ((fk (lambda () (pmatch v cs ...)))) (ppat v pat - (if (and g ...) (begin e0 e ...) (fk)) + (if (and g ...) (let () e0 e ...) (fk)) (fk)))) ((_ v (pat e0 e ...) cs ...) (let ((fk (lambda () (pmatch v cs ...)))) - (ppat v pat (begin e0 e ...) (fk)))))) + (ppat v pat (let () e0 e ...) (fk)))))) (define-syntax ppat (syntax-rules (_ quote unquote) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index ebf2b93d4..0a06e3dd0 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -89,7 +89,7 @@ (catch #t (lambda () (%start-stack #t thunk)) default-catch-handler - pre-unwind-handler-dispatch)) + default-pre-unwind-handler)) (define-macro (with-backtrace form) `(call-with-backtrace (lambda () ,form))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3854d4ab1..8ac209339 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \ tests/arbiters.test \ tests/asm-to-bytecode.test \ tests/bit-operations.test \ + tests/bytevectors.test \ tests/c-api.test \ tests/chars.test \ tests/common-list.test \ @@ -62,6 +63,7 @@ SCM_TESTS = tests/alist.test \ tests/q.test \ tests/r4rs.test \ tests/r5rs_pitfall.test \ + tests/r6rs-ports.test \ tests/ramap.test \ tests/reader.test \ tests/receive.test \ @@ -93,6 +95,7 @@ SCM_TESTS = tests/alist.test \ tests/syntax.test \ tests/threads.test \ tests/time.test \ + tests/tree-il.test \ tests/unif.test \ tests/version.test \ tests/weaks.test diff --git a/test-suite/lib.scm b/test-suite/lib.scm index c4ddf9e7c..3f09ce48a 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -317,20 +317,24 @@ (set! run-test local-run-test)) ;;; A short form for tests that are expected to pass, taken from Greg. -(defmacro pass-if (name . rest) - (if (and (null? rest) (pair? name)) - ;; presume this is a simple test, i.e. (pass-if (even? 2)) - ;; where the body should also be the name. - `(run-test ',name #t (lambda () ,name)) - `(run-test ,name #t (lambda () ,@rest)))) +(define-syntax pass-if + (syntax-rules () + ((_ name) + ;; presume this is a simple test, i.e. (pass-if (even? 2)) + ;; where the body should also be the name. + (run-test 'name #t (lambda () name))) + ((_ name rest ...) + (run-test name #t (lambda () rest ...))))) ;;; A short form for tests that are expected to fail, taken from Greg. -(defmacro expect-fail (name . rest) - (if (and (null? rest) (pair? name)) - ;; presume this is a simple test, i.e. (expect-fail (even? 2)) - ;; where the body should also be the name. - `(run-test ',name #f (lambda () ,name)) - `(run-test ,name #f (lambda () ,@rest)))) +(define-syntax expect-fail + (syntax-rules () + ((_ name) + ;; presume this is a simple test, i.e. (expect-fail (even? 2)) + ;; where the body should also be the name. + (run-test 'name #f (lambda () name))) + ((_ name rest ...) + (run-test name #f (lambda () rest ...))))) ;;; A helper function to implement the macros that test for exceptions. (define (run-test-exception name exception expect-pass thunk) @@ -362,12 +366,16 @@ (apply throw key proc message rest)))))))) ;;; A short form for tests that expect a certain exception to be thrown. -(defmacro pass-if-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest))) +(define-syntax pass-if-exception + (syntax-rules () + ((_ name exception body rest ...) + (run-test-exception name exception #t (lambda () body rest ...))))) ;;; A short form for tests expected to fail to throw a certain exception. -(defmacro expect-fail-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest))) +(define-syntax expect-fail-exception + (syntax-rules () + ((_ name exception body rest ...) + (run-test-exception name exception #f (lambda () body rest ...))))) ;;;; TEST NAMES diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test new file mode 100644 index 000000000..b2ae65c1f --- /dev/null +++ b/test-suite/tests/bytevectors.test @@ -0,0 +1,531 @@ +;;;; bytevectors.test --- Exercise the R6RS bytevector API. +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; 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 2.1 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-bytevector) + :use-module (test-suite lib) + :use-module (rnrs bytevector)) + +;;; Some of the tests in here are examples taken from the R6RS Standard +;;; Libraries document. + + +(with-test-prefix "2.2 General Operations" + + (pass-if "native-endianness" + (not (not (memq (native-endianness) '(big little))))) + + (pass-if "make-bytevector" + (and (bytevector? (make-bytevector 20)) + (bytevector? (make-bytevector 20 3)))) + + (pass-if "bytevector-length" + (= (bytevector-length (make-bytevector 20)) 20)) + + (pass-if "bytevector=?" + (and (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 7)) + (not (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 0)))))) + + +(with-test-prefix "2.3 Operations on Bytes and Octets" + + (pass-if "bytevector-{u8,s8}-ref" + (equal? '(-127 129 -1 255) + (let ((b1 (make-bytevector 16 -127)) + (b2 (make-bytevector 16 255))) + (list (bytevector-s8-ref b1 0) + (bytevector-u8-ref b1 0) + (bytevector-s8-ref b2 0) + (bytevector-u8-ref b2 0))))) + + (pass-if "bytevector-{u8,s8}-set!" + (equal? '(-126 130 -10 246) + (let ((b (make-bytevector 16 -127))) + + (bytevector-s8-set! b 0 -126) + (bytevector-u8-set! b 1 246) + + (list (bytevector-s8-ref b 0) + (bytevector-u8-ref b 0) + (bytevector-s8-ref b 1) + (bytevector-u8-ref b 1))))) + + (pass-if "bytevector->u8-list" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list + (let ((b (make-bytevector 6))) + (for-each (lambda (i v) + (bytevector-u8-set! b i v)) + (iota 6) + lst) + b))))) + + (pass-if "u8-list->bytevector" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list (u8-list->bytevector lst))))) + + (pass-if "bytevector-uint-{ref,set!} [small]" + (let ((b (make-bytevector 15))) + (bytevector-uint-set! b 0 #x1234 + (endianness little) 2) + (equal? (bytevector-uint-ref b 0 (endianness big) 2) + #x3412))) + + (pass-if "bytevector-uint-set! [large]" + (let ((b (make-bytevector 16))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector->u8-list b) + '(253 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 255)))) + + (pass-if "bytevector-uint-{ref,set!} [large]" + (let ((b (make-bytevector 120))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector-uint-ref b 0 (endianness little) 16) + #xfffffffffffffffffffffffffffffffd))) + + (pass-if "bytevector-sint-ref [small]" + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (equal? (bytevector-sint-ref b 0 (endianness big) 2) + (bytevector-sint-ref b 1 (endianness little) 2) + -16))) + + (pass-if "bytevector-sint-ref [large]" + (let ((b (make-bytevector 50))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector-sint-ref b 0 (endianness little) 16) + -3))) + + (pass-if "bytevector-sint-set! [small]" + (let ((b (make-bytevector 3))) + (bytevector-sint-set! b 0 -16 (endianness big) 2) + (bytevector-sint-set! b 1 -16 (endianness little) 2) + (equal? (bytevector->u8-list b) + '(#xff #xf0 #xff))))) + + +(with-test-prefix "2.4 Operations on Integers of Arbitrary Size" + + (pass-if "bytevector->sint-list" + (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (equal? (bytevector->sint-list b (endianness little) 2) + '(513 -253 513 513)))) + + (pass-if "bytevector->uint-list" + (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1)))) + (equal? (bytevector->uint-list b (endianness big) 2) + '(513 65283 513 513)))) + + (pass-if "bytevector->uint-list [empty]" + (let ((b (make-bytevector 0))) + (null? (bytevector->uint-list b (endianness big) 2)))) + + (pass-if-exception "bytevector->sint-list [out-of-range]" + exception:out-of-range + (bytevector->sint-list (make-bytevector 6) (endianness little) 8)) + + (pass-if "bytevector->sint-list [off-by-one]" + (equal? (bytevector->sint-list (make-bytevector 31 #xff) + (endianness little) 8) + '(-1 -1 -1))) + + (pass-if "{sint,uint}-list->bytevector" + (let ((b1 (sint-list->bytevector '(513 -253 513 513) + (endianness little) 2)) + (b2 (uint-list->bytevector '(513 65283 513 513) + (endianness little) 2)) + (b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (and (bytevector=? b1 b2) + (bytevector=? b2 b3)))) + + (pass-if "sint-list->bytevector [limits]" + (bytevector=? (sint-list->bytevector '(-32768 32767) + (endianness big) 2) + (let ((bv (make-bytevector 4))) + (bytevector-u8-set! bv 0 #x80) + (bytevector-u8-set! bv 1 #x00) + (bytevector-u8-set! bv 2 #x7f) + (bytevector-u8-set! bv 3 #xff) + bv))) + + (pass-if-exception "sint-list->bytevector [out-of-range]" + exception:out-of-range + (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big) + 2)) + + (pass-if-exception "uint-list->bytevector [out-of-range]" + exception:out-of-range + (uint-list->bytevector '(0 -1) (endianness big) 2))) + + +(with-test-prefix "2.5 Operations on 16-Bit Integers" + + (pass-if "bytevector-u16-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u16-ref b 14 (endianness little)) + #xfdff) + (equal? (bytevector-u16-ref b 14 (endianness big)) + #xfffd)))) + + (pass-if "bytevector-s16-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s16-ref b 14 (endianness little)) + -513) + (equal? (bytevector-s16-ref b 14 (endianness big)) + -3)))) + + (pass-if "bytevector-s16-ref [unaligned]" + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -16))) + + (pass-if "bytevector-{u16,s16}-ref" + (let ((b (make-bytevector 2))) + (bytevector-u16-set! b 0 44444 (endianness little)) + (and (equal? (bytevector-u16-ref b 0 (endianness little)) + 44444) + (equal? (bytevector-s16-ref b 0 (endianness little)) + (- 44444 65536))))) + + (pass-if "bytevector-native-{u16,s16}-{ref,set!}" + (let ((b (make-bytevector 2))) + (bytevector-u16-native-set! b 0 44444) + (and (equal? (bytevector-u16-native-ref b 0) + 44444) + (equal? (bytevector-s16-native-ref b 0) + (- 44444 65536))))) + + (pass-if "bytevector-s16-{ref,set!} [unaligned]" + (let ((b (make-bytevector 3))) + (bytevector-s16-set! b 1 -77 (endianness little)) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -77)))) + + +(with-test-prefix "2.6 Operations on 32-bit Integers" + + (pass-if "bytevector-u32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u32-ref b 12 (endianness little)) + #xfdffffff) + (equal? (bytevector-u32-ref b 12 (endianness big)) + #xfffffffd)))) + + (pass-if "bytevector-s32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s32-ref b 12 (endianness little)) + -33554433) + (equal? (bytevector-s32-ref b 12 (endianness big)) + -3)))) + + (pass-if "bytevector-{u32,s32}-ref" + (let ((b (make-bytevector 4))) + (bytevector-u32-set! b 0 2222222222 (endianness little)) + (and (equal? (bytevector-u32-ref b 0 (endianness little)) + 2222222222) + (equal? (bytevector-s32-ref b 0 (endianness little)) + (- 2222222222 (expt 2 32)))))) + + (pass-if "bytevector-{u32,s32}-native-{ref,set!}" + (let ((b (make-bytevector 4))) + (bytevector-u32-native-set! b 0 2222222222) + (and (equal? (bytevector-u32-native-ref b 0) + 2222222222) + (equal? (bytevector-s32-native-ref b 0) + (- 2222222222 (expt 2 32))))))) + + +(with-test-prefix "2.7 Operations on 64-bit Integers" + + (pass-if "bytevector-u64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u64-ref b 8 (endianness little)) + #xfdffffffffffffff) + (equal? (bytevector-u64-ref b 8 (endianness big)) + #xfffffffffffffffd)))) + + (pass-if "bytevector-s64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s64-ref b 8 (endianness little)) + -144115188075855873) + (equal? (bytevector-s64-ref b 8 (endianness big)) + -3)))) + + (pass-if "bytevector-{u64,s64}-ref" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-set! b 0 big (endianness little)) + (and (equal? (bytevector-u64-ref b 0 (endianness little)) + big) + (equal? (bytevector-s64-ref b 0 (endianness little)) + (- big (expt 2 64)))))) + + (pass-if "bytevector-{u64,s64}-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-native-set! b 0 big) + (and (equal? (bytevector-u64-native-ref b 0) + big) + (equal? (bytevector-s64-native-ref b 0) + (- big (expt 2 64)))))) + + (pass-if "ref/set! with zero" + (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)))))) + + +(with-test-prefix "2.8 Operations on IEEE-754 Representations" + + (pass-if "bytevector-ieee-single-native-{ref,set!}" + (let ((b (make-bytevector 4)) + (number 3.00)) + (bytevector-ieee-single-native-set! b 0 number) + (equal? (bytevector-ieee-single-native-ref b 0) + number))) + + (pass-if "bytevector-ieee-single-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-single-set! b 0 number (endianness little)) + (bytevector-ieee-single-set! b 4 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 0 (endianness little)) + (bytevector-ieee-single-ref b 4 (endianness big))))) + + (pass-if "bytevector-ieee-single-{ref,set!} [unaligned]" + (let ((b (make-bytevector 9)) + (number 3.14)) + (bytevector-ieee-single-set! b 1 number (endianness little)) + (bytevector-ieee-single-set! b 5 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 1 (endianness little)) + (bytevector-ieee-single-ref b 5 (endianness big))))) + + (pass-if "bytevector-ieee-double-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-double-native-set! b 0 number) + (equal? (bytevector-ieee-double-native-ref b 0) + number))) + + (pass-if "bytevector-ieee-double-{ref,set!}" + (let ((b (make-bytevector 16)) + (number 3.14)) + (bytevector-ieee-double-set! b 0 number (endianness little)) + (bytevector-ieee-double-set! b 8 number (endianness big)) + (equal? (bytevector-ieee-double-ref b 0 (endianness little)) + (bytevector-ieee-double-ref b 8 (endianness big)))))) + + +(define (with-locale locale thunk) + ;; Run THUNK under LOCALE. + (let ((original-locale (setlocale LC_ALL))) + (catch 'system-error + (lambda () + (setlocale LC_ALL locale)) + (lambda (key . args) + (throw 'unresolved))) + + (dynamic-wind + (lambda () + #t) + thunk + (lambda () + (setlocale LC_ALL original-locale))))) + +(define (with-latin1-locale thunk) + ;; Try out several ISO-8859-1 locales and run THUNK under the one that + ;; works (if any). + (define %locales + (map (lambda (name) + (string-append name ".ISO-8859-1")) + '("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))) + + (let loop ((locales %locales)) + (if (null? locales) + (throw 'unresolved) + (catch 'unresolved + (lambda () + (with-locale (car locales) thunk)) + (lambda (key . args) + (loop (cdr locales))))))) + + +;; Default to the C locale for the following tests. +(setlocale LC_ALL "C") + + +(with-test-prefix "2.9 Operations on Strings" + + (pass-if "string->utf8" + (let* ((str "hello, world") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (string-length str)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (pass-if "string->utf8 [latin-1]" + (with-latin1-locale + (lambda () + (let* ((str "hé, ça va bien ?") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (+ 2 (string-length str)))))))) + + (pass-if "string->utf16" + (let* ((str "hello, world") + (utf16 (string->utf16 str))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness big) 2)))))) + + (pass-if "string->utf16 [little]" + (let* ((str "hello, world") + (utf16 (string->utf16 str (endianness little)))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness little) 2)))))) + + + (pass-if "string->utf32" + (let* ((str "hello, world") + (utf32 (string->utf32 str))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness big) 4)))))) + + (pass-if "string->utf32 [little]" + (let* ((str "hello, world") + (utf32 (string->utf32 str (endianness little)))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness little) 4)))))) + + (pass-if "utf8->string" + (let* ((utf8 (u8-list->bytevector (map char->integer + (string->list "hello, world")))) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (bytevector-length utf8)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (pass-if "utf8->string [latin-1]" + (with-latin1-locale + (lambda () + (let* ((utf8 (string->utf8 "hé, ça va bien ?")) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (- (bytevector-length utf8) 2))))))) + + (pass-if "utf16->string" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 2)) + (str (utf16->string utf16))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness big) + 2)))))) + + (pass-if "utf16->string [little]" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 2)) + (str (utf16->string utf16 (endianness little)))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness little) + 2)))))) + (pass-if "utf32->string" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 4)) + (str (utf32->string utf32))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness big) + 4)))))) + + (pass-if "utf32->string [little]" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 4)) + (str (utf32->string utf32 (endianness little)))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness little) + 4))))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index d83167f34..7324d7795 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -18,45 +18,10 @@ (define-module (test-suite tests compiler) :use-module (test-suite lib) :use-module (test-suite guile-test) - :use-module (system vm program)) + :use-module (system base compile)) -(with-test-prefix "environments" +(with-test-prefix "basic" - (pass-if "compile-time-environment in evaluator" - (eq? (primitive-eval '(compile-time-environment)) #f)) - - (pass-if "compile-time-environment in compiler" - (equal? (compile '(compile-time-environment)) - (cons (current-module) - (cons '() '())))) - - (let ((env (compile - '(let ((x 0)) (set! x 1) (compile-time-environment))))) - (pass-if "compile-time-environment in compiler, heap-allocated var" - (equal? env - (cons (current-module) - (cons '((x . 0)) '(1))))) - - ;; fixme: compiling with #t or module - (pass-if "recompiling with environment" - (equal? ((compile '(lambda () x) #:env env)) - 1)) - - (pass-if "recompiling with environment/2" - (equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env)) - 2)) - - (pass-if "recompiling with environment/3" - (equal? ((compile '(lambda () x) #:env env)) - 2)) - ) - - (pass-if "compile environment is #f" - (equal? ((compile '(lambda () 10))) - 10)) - - (pass-if "compile environment is a module" - (equal? ((compile '(lambda () 10) #:env (current-module))) - 10)) - ) \ No newline at end of file + (pass-if "compile to value" + (equal? (compile 1) 1))) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 7a22f0dff..e5ef34bb0 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -24,6 +24,9 @@ (define exception:bad-expression (cons 'syntax-error "Bad expression")) +(define exception:failed-match + (cons 'syntax-error "failed to match any pattern")) + ;;; ;;; miscellaneous @@ -85,17 +88,19 @@ ;; Macros are accepted as function parameters. ;; Functions that 'apply' macros are rewritten!!! - (expect-fail-exception "macro as argument" - exception:wrong-type-arg - (let ((f (lambda (p a b) (p a b)))) - (f and #t #t))) + (pass-if-exception "macro as argument" + exception:failed-match + (primitive-eval + '(let ((f (lambda (p a b) (p a b)))) + (f and #t #t)))) - (expect-fail-exception "passing macro as parameter" - exception:wrong-type-arg - (let* ((f (lambda (p a b) (p a b))) - (foo (procedure-source f))) - (f and #t #t) - (equal? (procedure-source f) foo))) + (pass-if-exception "passing macro as parameter" + exception:failed-match + (primitive-eval + '(let* ((f (lambda (p a b) (p a b))) + (foo (procedure-source f))) + (f and #t #t) + (equal? (procedure-source f) foo)))) )) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test new file mode 100644 index 000000000..204f37144 --- /dev/null +++ b/test-suite/tests/r6rs-ports.test @@ -0,0 +1,455 @@ +;;;; r6rs-ports.test --- Exercise the R6RS I/O port API. +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; 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 2.1 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-io-ports) + :use-module (test-suite lib) + :use-module (srfi srfi-1) + :use-module (srfi srfi-11) + :use-module (rnrs io ports) + :use-module (rnrs bytevector)) + +;;; All these tests assume Guile 1.8's port system, where characters are +;;; treated as octets. + + +(with-test-prefix "7.2.5 End-of-File Object" + + (pass-if "eof-object" + (and (eqv? (eof-object) (eof-object)) + (eq? (eof-object) (eof-object))))) + + +(with-test-prefix "7.2.8 Binary Input" + + (pass-if "get-u8" + (let ((port (open-input-string "A"))) + (and (= (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "lookahead-u8" + (let ((port (open-input-string "A"))) + (and (= (char->integer #\A) (lookahead-u8 port)) + (not (eof-object? port)) + (= (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "get-bytevector-n [short]" + (let* ((port (open-input-string "GNU Guile")) + (bv (get-bytevector-n port 4))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-n [long]" + (let* ((port (open-input-string "GNU Guile")) + (bv (get-bytevector-n port 256))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU Guile")))))) + + (pass-if-exception "get-bytevector-n with closed port" + exception:wrong-type-arg + + (let ((port (%make-void-port "r"))) + + (close-port port) + (get-bytevector-n port 3))) + + (pass-if "get-bytevector-n! [short]" + (let* ((port (open-input-string "GNU Guile")) + (bv (make-bytevector 4)) + (read (get-bytevector-n! port bv 0 4))) + (and (equal? read 4) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-n! [long]" + (let* ((str "GNU Guile") + (port (open-input-string str)) + (bv (make-bytevector 256)) + (read (get-bytevector-n! port bv 0 256))) + (and (equal? read (string-length str)) + (equal? (map (lambda (i) + (bytevector-u8-ref bv i)) + (iota read)) + (map char->integer (string->list str)))))) + + (pass-if "get-bytevector-some [simple]" + (let* ((str "GNU Guile") + (port (open-input-string str)) + (bv (get-bytevector-some port))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list str)))))) + + (pass-if "get-bytevector-some [only-some]" + (let* ((str "GNU Guile") + (index 0) + (port (make-soft-port + (vector #f #f #f + (lambda () + (if (>= index (string-length str)) + (eof-object) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + c))) + (lambda () #t) + (lambda () + ;; Number of readily available octets: falls to + ;; zero after 4 octets have been read. + (- 4 (modulo index 5)))) + "r")) + (bv (get-bytevector-some port))) + (and (bytevector? bv) + (= index 4) + (= (bytevector-length bv) index) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-all" + (let* ((str "GNU Guile") + (index 0) + (port (make-soft-port + (vector #f #f #f + (lambda () + (if (>= index (string-length str)) + (eof-object) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + c))) + (lambda () #t) + (let ((cont? #f)) + (lambda () + ;; Number of readily available octets: falls to + ;; zero after 4 octets have been read and then + ;; starts again. + (let ((a (if cont? + (- (string-length str) index) + (- 4 (modulo index 5))))) + (if (= 0 a) (set! cont? #t)) + a)))) + "r")) + (bv (get-bytevector-all port))) + (and (bytevector? bv) + (= index (string-length str)) + (= (bytevector-length bv) (string-length str)) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list str))))))) + + +(define (make-soft-output-port) + (let* ((bv (make-bytevector 1024)) + (read-index 0) + (write-index 0) + (write-char (lambda (chr) + (bytevector-u8-set! bv write-index + (char->integer chr)) + (set! write-index (+ 1 write-index))))) + (make-soft-port + (vector write-char + (lambda (str) ;; write-string + (for-each write-char (string->list str))) + (lambda () #t) ;; flush-output + (lambda () ;; read-char + (if (>= read-index (bytevector-length bv)) + (eof-object) + (let ((c (bytevector-u8-ref bv read-index))) + (set! read-index (+ read-index 1)) + (integer->char c)))) + (lambda () #t)) ;; close-port + "rw"))) + +(with-test-prefix "7.2.11 Binary Output" + + (pass-if "put-u8" + (let ((port (make-soft-output-port))) + (put-u8 port 77) + (equal? (get-u8 port) 77))) + + (pass-if "put-bytevector [2 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256))) + (put-bytevector port bv) + (equal? (bytevector->u8-list bv) + (bytevector->u8-list + (get-bytevector-n port (bytevector-length bv)))))) + + (pass-if "put-bytevector [3 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256)) + (start 10)) + (put-bytevector port bv start) + (equal? (drop (bytevector->u8-list bv) start) + (bytevector->u8-list + (get-bytevector-n port (- (bytevector-length bv) start)))))) + + (pass-if "put-bytevector [4 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256)) + (start 10) + (count 77)) + (put-bytevector port bv start count) + (equal? (take (drop (bytevector->u8-list bv) start) count) + (bytevector->u8-list + (get-bytevector-n port count))))) + + (pass-if-exception "put-bytevector with closed port" + exception:wrong-type-arg + + (let* ((bv (make-bytevector 4)) + (port (%make-void-port "w"))) + + (close-port port) + (put-bytevector port bv)))) + + +(with-test-prefix "7.2.7 Input Ports" + + ;; This section appears here so that it can use the binary input + ;; primitives. + + (pass-if "open-bytevector-input-port [1 arg]" + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv)) + (read-to-string + (lambda (port) + (let loop ((chr (read-char port)) + (result '())) + (if (eof-object? chr) + (apply string (reverse! result)) + (loop (read-char port) + (cons chr result))))))) + + (equal? (read-to-string port) str))) + + (pass-if-exception "bytevector-input-port is read-only" + exception:wrong-type-arg + + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv #f))) + + (write "hello" port))) + + (pass-if "bytevector input port supports seeking" + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv #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-exception "make-custom-binary-input-port [wrong-num-args]" + exception:wrong-num-args + + ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully + ;; optional. + (make-custom-binary-input-port "port" (lambda args #t))) + + (pass-if "make-custom-binary-input-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)))) + (port (make-custom-binary-input-port "the port" read! + #f #f #f))) + + (bytevector=? (get-bytevector-all port) source))) + + (pass-if "custom binary input 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-port "the port" read! + #f #f #f))) + (not (or (port-has-port-position? port) + (port-has-set-port-position!? port))))) + + (pass-if "custom binary input 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-port "the port" read! + 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 "custom binary input 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-port "the port" read! + get-pos set-pos! + close!))) + + (close-port port) + closed?))) + + +(with-test-prefix "8.2.10 Output ports" + + (pass-if "open-bytevector-output-port" + (let-values (((port get-content) + (open-bytevector-output-port #f))) + (let ((source (make-bytevector 7777))) + (put-bytevector port source) + (and (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "open-bytevector-output-port [put-u8]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (put-u8 port 77) + (and (bytevector=? (get-content) (make-bytevector 1 77)) + (bytevector=? (get-content) (make-bytevector 0))))) + + (pass-if "open-bytevector-output-port [display]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (display "hello" port) + (and (bytevector=? (get-content) (string->utf8 "hello")) + (bytevector=? (get-content) (make-bytevector 0))))) + + (pass-if "bytevector output port supports `port-position'" + (let-values (((port get-content) + (open-bytevector-output-port))) + (let ((source (make-bytevector 7777)) + (overwrite (make-bytevector 33))) + (and (port-has-port-position? port) + (port-has-set-port-position!? port) + (begin + (put-bytevector port source) + (= (bytevector-length source) + (port-position port))) + (begin + (set-port-position! port 10) + (= 10 (port-position port))) + (begin + (put-bytevector port overwrite) + (bytevector-copy! overwrite 0 source 10 + (bytevector-length overwrite)) + (= (port-position port) + (+ 10 (bytevector-length overwrite)))) + (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "make-custom-binary-output" + (let ((port (make-custom-binary-output-port "cbop" + (lambda (x y z) 0) + #f #f #f))) + (and (output-port? port) + (binary-port? port) + (not (port-has-port-position? port)) + (not (port-has-set-port-position!? port))))) + + (pass-if "make-custom-binary-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-output-port "cbop" write! + #f #f #f))) + (put-bytevector port source) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if "make-custom-binary-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-output-port "cbop" write! + #f #f #f))) + (put-bytevector port source) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 0b6f9a468..bd34e4db0 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -35,6 +35,8 @@ (cons 'read-error "end of file in string constant$")) (define exception:illegal-escape (cons 'read-error "illegal character in escape sequence: .*$")) +(define exception:missing-expression + (cons 'read-error "no expression after #;")) (define (read-string s) @@ -194,3 +196,36 @@ (and (equal? (source-property sexp 'line) 0) (equal? (source-property sexp 'column) 0))))) +(with-test-prefix "#;" + (for-each + (lambda (pair) + (pass-if (car pair) + (equal? (with-input-from-string (car pair) read) (cdr pair)))) + + '(("#;foo 10". 10) + ("#;(10 20 30) foo" . foo) + ("#; (10 20 30) foo" . foo) + ("#;\n10\n20" . 20))) + + (pass-if "#;foo" + (eof-object? (with-input-from-string "#;foo" read))) + + (pass-if-exception "#;" + exception:missing-expression + (with-input-from-string "#;" read)) + (pass-if-exception "#;(" + exception:eof + (with-input-from-string "#;(" read))) + +(with-test-prefix "#'" + (for-each + (lambda (pair) + (pass-if (car pair) + (equal? (with-input-from-string (car pair) read) (cdr pair)))) + + '(("#'foo". (syntax foo)) + ("#`foo" . (quasisyntax foo)) + ("#,foo" . (unsyntax foo)) + ("#,@foo" . (unsyntax-splicing foo))))) + + diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index fbacb15a3..4841f2ef1 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -50,6 +50,9 @@ (define %some-variable #f) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) + (with-test-prefix "set!" (with-test-prefix "target is not procedure with setter" @@ -59,7 +62,7 @@ (set! (symbol->string 'x) 1)) (pass-if-exception "(set! '#f 1)" - exception:bad-variable + exception:bad-quote (eval '(set! '#f 1) (interaction-environment)))) (with-test-prefix "target uses macro" @@ -72,7 +75,7 @@ ;; The `(quote x)' below used to be memoized as an infinite list before ;; Guile 1.8.3. (pass-if-exception "(set! 'x 1)" - exception:bad-variable + exception:bad-quote (eval '(set! 'x 1) (interaction-environment))))) ;; diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index fa309e6ce..3c7090643 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -21,8 +21,13 @@ (define-module (test-suite test-srfi-18) #:use-module (test-suite lib)) -(and (provided? 'threads) - (use-modules (srfi srfi-18)) +;; two expressions so that the srfi-18 import is in effect for expansion +;; of the rest +(if (provided? 'threads) + (use-modules (srfi srfi-18))) + +(and + (provided? 'threads) (with-test-prefix "current-thread" diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test index bd6977333..b23d3e20f 100644 --- a/test-suite/tests/srfi-31.test +++ b/test-suite/tests/srfi-31.test @@ -23,7 +23,7 @@ (with-test-prefix "rec special form" (pass-if-exception "bogus variable" '(misc-error . ".*") - (rec #:foo)) + (sc-expand '(rec #:foo))) (pass-if "rec expressions" (let ((ones-list (rec ones (cons 1 (delay ones))))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 1277e5204..aa2e05127 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -21,6 +21,11 @@ :use-module (test-suite lib)) +(define exception:generic-syncase-error + (cons 'syntax-error "source expression failed to match")) +(define exception:unexpected-syntax + (cons 'syntax-error "unexpected syntax")) + (define exception:bad-expression (cons 'syntax-error "Bad expression")) @@ -29,22 +34,32 @@ (define exception:missing-expr (cons 'syntax-error "Missing expression")) (define exception:missing-body-expr - (cons 'syntax-error "Missing body expression")) + (cons 'syntax-error "no expressions in body")) (define exception:extra-expr (cons 'syntax-error "Extra expression")) (define exception:illegal-empty-combination (cons 'syntax-error "Illegal empty combination")) +(define exception:bad-lambda + '(syntax-error . "bad lambda")) +(define exception:bad-let + '(syntax-error . "bad let ")) +(define exception:bad-letrec + '(syntax-error . "bad letrec ")) +(define exception:bad-set! + '(syntax-error . "bad set!")) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) (define exception:bad-bindings (cons 'syntax-error "Bad bindings")) (define exception:bad-binding (cons 'syntax-error "Bad binding")) (define exception:duplicate-binding - (cons 'syntax-error "Duplicate binding")) + (cons 'syntax-error "duplicate bound variable")) (define exception:bad-body (cons 'misc-error "^bad body")) (define exception:bad-formals - (cons 'syntax-error "Bad formals")) + '(syntax-error . "invalid parameter list")) (define exception:bad-formal (cons 'syntax-error "Bad formal")) (define exception:duplicate-formal @@ -67,13 +82,13 @@ (with-test-prefix "Bad argument list" (pass-if-exception "improper argument list of length 1" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo . 1)) (interaction-environment))) (pass-if-exception "improper argument list of length 2" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo 1 . 2)) (interaction-environment)))) @@ -88,7 +103,7 @@ ;; Fixed on 2001-3-3 (pass-if-exception "empty parentheses \"()\"" - exception:illegal-empty-combination + exception:unexpected-syntax (eval '() (interaction-environment))))) @@ -106,28 +121,32 @@ (with-test-prefix "unquote-splicing" (pass-if-exception "extra arguments" - exception:missing/extra-expr - (quasiquote ((unquote-splicing (list 1 2) (list 3 4))))))) + '(syntax-error . "unquote-splicing takes exactly one argument") + (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))) + (interaction-environment))))) (with-test-prefix "begin" (pass-if "legal (begin)" - (begin) - #t) + (eval '(begin (begin) #t) (interaction-environment))) (with-test-prefix "unmemoization" + ;; FIXME. I have no idea why, but the expander is filling in (if #f + ;; #f) as the second arm of the if, if the second arm is missing. I + ;; thought I made it not do that. But in the meantime, let's adapt, + ;; since that's not what we're testing. + (pass-if "normal begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))) - (foo) ; make sure, memoization has been performed + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))) (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))) (pass-if "redundant nested begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))) + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))) (pass-if "redundant begin at start of body" (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized @@ -135,10 +154,20 @@ (equal? (procedure-source foo) '(lambda () (begin (+ 1) (+ 2))))))) - (expect-fail-exception "illegal (begin)" - exception:bad-body - (if #t (begin)) - #t)) + (pass-if-exception "illegal (begin)" + exception:generic-syncase-error + (eval '(begin (if #t (begin)) #t) (interaction-environment)))) + +(define-syntax matches? + (syntax-rules (_) + ((_ (op arg ...) pat) (let ((x (op arg ...))) + (matches? x pat))) + ((_ x ()) (null? x)) + ((_ x (a . b)) (and (pair? x) + (matches? (car x) a) + (matches? (cdr x) b))) + ((_ x _) #t) + ((_ x pat) (equal? x 'pat)))) (with-test-prefix "lambda" @@ -146,30 +175,28 @@ (pass-if "normal lambda" (let ((foo (lambda () (lambda (x y) (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) (+ _ _)))))) (pass-if "lambda with documentation" (let ((foo (lambda () (lambda (x y) "docstring" (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) "docstring" (+ x y))))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) "docstring" (+ _ _))))))) (with-test-prefix "bad formals" (pass-if-exception "(lambda)" - exception:missing-expr + exception:bad-lambda (eval '(lambda) (interaction-environment))) (pass-if-exception "(lambda . \"foo\")" - exception:bad-expression + exception:bad-lambda (eval '(lambda . "foo") (interaction-environment))) (pass-if-exception "(lambda \"foo\")" - exception:missing-expr + exception:bad-lambda (eval '(lambda "foo") (interaction-environment))) @@ -179,22 +206,22 @@ (interaction-environment))) (pass-if-exception "(lambda (x 1) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x 1) 2) (interaction-environment))) (pass-if-exception "(lambda (1 x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (1 x) 2) (interaction-environment))) (pass-if-exception "(lambda (x \"a\") 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x "a") 2) (interaction-environment))) (pass-if-exception "(lambda (\"a\" x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda ("a" x) 2) (interaction-environment)))) @@ -202,20 +229,20 @@ ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x) 1) (interaction-environment))) ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x x) 1) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(lambda ())" - exception:missing-expr + exception:bad-lambda (eval '(lambda ()) (interaction-environment))))) @@ -225,9 +252,8 @@ (pass-if "normal let" (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -238,42 +264,42 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let)" - exception:missing-expr + exception:bad-let (eval '(let) (interaction-environment))) (pass-if-exception "(let 1)" - exception:missing-expr + exception:bad-let (eval '(let 1) (interaction-environment))) (pass-if-exception "(let (x))" - exception:missing-expr + exception:bad-let (eval '(let (x)) (interaction-environment))) (pass-if-exception "(let ((x)))" - exception:missing-expr + exception:bad-let (eval '(let ((x))) (interaction-environment))) (pass-if-exception "(let (x) 1)" - exception:bad-binding + exception:bad-let (eval '(let (x) 1) (interaction-environment))) (pass-if-exception "(let ((x)) 3)" - exception:bad-binding + exception:bad-let (eval '(let ((x)) 3) (interaction-environment))) (pass-if-exception "(let ((x 1) y) x)" - exception:bad-binding + exception:bad-let (eval '(let ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let ((1 2)) 3)" - exception:bad-variable + exception:bad-let (eval '(let ((1 2)) 3) (interaction-environment)))) @@ -287,12 +313,12 @@ (with-test-prefix "bad body" (pass-if-exception "(let ())" - exception:missing-expr + exception:bad-let (eval '(let ()) (interaction-environment))) (pass-if-exception "(let ((x 1)))" - exception:missing-expr + exception:bad-let (eval '(let ((x 1))) (interaction-environment))))) @@ -307,19 +333,19 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let x (y))" - exception:missing-expr + exception:bad-let (eval '(let x (y)) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let x ())" - exception:missing-expr + exception:bad-let (eval '(let x ()) (interaction-environment))) (pass-if-exception "(let x ((y 1)))" - exception:missing-expr + exception:bad-let (eval '(let x ((y 1))) (interaction-environment))))) @@ -329,19 +355,16 @@ (pass-if "normal let*" (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let* ((x 1) (y 2)) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _))))))) (pass-if "let* without bindings" (let ((foo (lambda () (let ((x 1) (y 2)) (let* () (and (= x 1) (= y 2))))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((x 1) (y 2)) - (let* () - (and (= x 1) (= y 2))))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) + (if (= _ 1) (= _ 2) #f))))))) (with-test-prefix "bindings" @@ -361,59 +384,59 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let*)" - exception:missing-expr + exception:generic-syncase-error (eval '(let*) (interaction-environment))) (pass-if-exception "(let* 1)" - exception:missing-expr + exception:generic-syncase-error (eval '(let* 1) (interaction-environment))) (pass-if-exception "(let* (x))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* (x)) (interaction-environment))) (pass-if-exception "(let* (x) 1)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* (x) 1) (interaction-environment))) (pass-if-exception "(let* ((x)) 3)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x)) 3) (interaction-environment))) (pass-if-exception "(let* ((x 1) y) x)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let* x ())" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x ()) (interaction-environment))) (pass-if-exception "(let* x (y))" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x (y)) (interaction-environment))) (pass-if-exception "(let* ((1 2)) 3)" - exception:bad-variable + exception:generic-syncase-error (eval '(let* ((1 2)) 3) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let* ())" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ()) (interaction-environment))) (pass-if-exception "(let* ((x 1)))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ((x 1))) (interaction-environment))))) @@ -423,9 +446,8 @@ (pass-if "normal letrec" (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (letrec ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (letrec ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -437,47 +459,47 @@ (with-test-prefix "bad bindings" (pass-if-exception "(letrec)" - exception:missing-expr + exception:bad-letrec (eval '(letrec) (interaction-environment))) (pass-if-exception "(letrec 1)" - exception:missing-expr + exception:bad-letrec (eval '(letrec 1) (interaction-environment))) (pass-if-exception "(letrec (x))" - exception:missing-expr + exception:bad-letrec (eval '(letrec (x)) (interaction-environment))) (pass-if-exception "(letrec (x) 1)" - exception:bad-binding + exception:bad-letrec (eval '(letrec (x) 1) (interaction-environment))) (pass-if-exception "(letrec ((x)) 3)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x)) 3) (interaction-environment))) (pass-if-exception "(letrec ((x 1) y) x)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x 1) y) x) (interaction-environment))) (pass-if-exception "(letrec x ())" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x ()) (interaction-environment))) (pass-if-exception "(letrec x (y))" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x (y)) (interaction-environment))) (pass-if-exception "(letrec ((1 2)) 3)" - exception:bad-variable + exception:bad-letrec (eval '(letrec ((1 2)) 3) (interaction-environment)))) @@ -491,12 +513,12 @@ (with-test-prefix "bad body" (pass-if-exception "(letrec ())" - exception:missing-expr + exception:bad-letrec (eval '(letrec ()) (interaction-environment))) (pass-if-exception "(letrec ((x 1)))" - exception:missing-expr + exception:bad-letrec (eval '(letrec ((x 1))) (interaction-environment))))) @@ -508,17 +530,17 @@ (let ((foo (lambda (x) (if x (+ 1) (+ 2))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (if x (+ 1) (+ 2)))))) + (matches? (procedure-source foo) + (lambda (_) (if _ (+ 1) (+ 2)))))) - (pass-if "if without else" + (expect-fail "if without else" (let ((foo (lambda (x) (if x (+ 1))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed (equal? (procedure-source foo) '(lambda (x) (if x (+ 1)))))) - (pass-if "if #f without else" + (expect-fail "if #f without else" (let ((foo (lambda () (if #f #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) @@ -527,12 +549,12 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(if)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if) (interaction-environment))) (pass-if-exception "(if 1 2 3 4)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if 1 2 3 4) (interaction-environment))))) @@ -594,78 +616,77 @@ (eq? 'ok (cond (#t identity =>) (else #f))))) (pass-if-exception "missing recipient" - '(syntax-error . "Missing recipient") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity =>))) (pass-if-exception "extra recipient" - '(syntax-error . "Extra expression") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity => identity identity)))) (with-test-prefix "unmemoization" + ;; FIXME: the (if #f #f) is a hack! (pass-if "normal clauses" - (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed + (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz))))) (equal? (procedure-source foo) - '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))) + '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f))))))) (pass-if "else" (let ((foo (lambda () (cond (else 'bar))))) - (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (cond (else 'bar)))))) + '(lambda () 'bar)))) + ;; FIXME: the (if #f #f) is a hack! (pass-if "=>" (let ((foo (lambda () (cond (#t => identity))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (cond (#t => identity))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ #t)) + (if _ (identity _) (if #f #f)))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(cond)" - exception:missing-clauses + exception:generic-syncase-error (eval '(cond) (interaction-environment))) (pass-if-exception "(cond #t)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond #t) (interaction-environment))) (pass-if-exception "(cond 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1) (interaction-environment))) (pass-if-exception "(cond 1 2)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2) (interaction-environment))) (pass-if-exception "(cond 1 2 3)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3) (interaction-environment))) (pass-if-exception "(cond 1 2 3 4)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3 4) (interaction-environment))) (pass-if-exception "(cond ())" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond ()) (interaction-environment))) (pass-if-exception "(cond () 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond () 1) (interaction-environment))) (pass-if-exception "(cond (1) 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond (1) 1) (interaction-environment)))) @@ -683,7 +704,7 @@ (with-test-prefix "case is hygienic" (pass-if-exception "bound 'else is handled correctly" - exception:bad-case-labels + exception:generic-syncase-error (eval '(let ((else #f)) (case 1 (else #f))) (interaction-environment)))) @@ -691,79 +712,83 @@ (pass-if "normal clauses" (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '(2)) + 'baz + 'foobar)))))) (pass-if "empty labels" (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '()) + 'baz + 'foobar))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(case)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case) (interaction-environment))) (pass-if-exception "(case . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case . "foo") (interaction-environment))) (pass-if-exception "(case 1)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case 1) (interaction-environment))) (pass-if-exception "(case 1 . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 . "foo") (interaction-environment))) (pass-if-exception "(case 1 \"foo\")" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 "foo") (interaction-environment))) (pass-if-exception "(case 1 ())" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ()) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\"))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ("foo")) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\" \"bar\"))" - exception:bad-case-labels + exception:generic-syncase-error (eval '(case 1 ("foo" "bar")) (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 ((2) "bar") . "foo") (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") (else))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ((2) "bar") (else)) (interaction-environment))) (pass-if-exception "(case 1 (else #f) . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 (else #f) . "foo") (interaction-environment))) (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:misplaced-else-clause + exception:generic-syncase-error (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) @@ -780,14 +805,6 @@ (eval '(define round round) m) (eq? (module-ref m 'round) round))) - (with-test-prefix "currying" - - (pass-if "(define ((foo)) #f)" - (eval '(begin - (define ((foo)) #t) - ((foo))) - (interaction-environment)))) - (with-test-prefix "unmemoization" (pass-if "definition unmemoized without prior execution" @@ -809,7 +826,7 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(define)" - exception:missing-expr + exception:generic-syncase-error (eval '(define) (interaction-environment))))) @@ -886,34 +903,10 @@ 'ok) (bar)) (foo) - (equal? + (matches? (procedure-source foo) - '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar))))) - (interaction-environment)))) - -(with-test-prefix "do" - - (with-test-prefix "unmemoization" - - (pass-if "normal case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i)))))) - - (pass-if "reduced case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here - ((> i 9) (+ i j)) - (identity i)))))))) + (lambda () (letrec ((_ (lambda () (quote ok)))) (_))))) + (current-module)))) (with-test-prefix "set!" @@ -922,50 +915,50 @@ (pass-if "normal set!" (let ((foo (lambda (x) (set! x (+ 1 x))))) (foo 1) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (set! x (+ 1 x))))))) + (matches? (procedure-source foo) + (lambda (_) (set! _ (+ 1 _))))))) (with-test-prefix "missing or extra expressions" (pass-if-exception "(set!)" - exception:missing/extra-expr + exception:bad-set! (eval '(set!) (interaction-environment))) (pass-if-exception "(set! 1)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1) (interaction-environment))) (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1 2 3) (interaction-environment)))) (with-test-prefix "bad variable" (pass-if-exception "(set! \"\" #t)" - exception:bad-variable + exception:bad-set! (eval '(set! "" #t) (interaction-environment))) (pass-if-exception "(set! 1 #t)" - exception:bad-variable + exception:bad-set! (eval '(set! 1 #t) (interaction-environment))) (pass-if-exception "(set! #t #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #t #f) (interaction-environment))) (pass-if-exception "(set! #f #t)" - exception:bad-variable + exception:bad-set! (eval '(set! #f #t) (interaction-environment))) (pass-if-exception "(set! #\\space #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #\space #f) (interaction-environment))))) @@ -974,12 +967,12 @@ (with-test-prefix "missing or extra expression" (pass-if-exception "(quote)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote) (interaction-environment))) (pass-if-exception "(quote a b)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote a b) (interaction-environment))))) @@ -1010,46 +1003,27 @@ (do ((n 0 (1+ n))) ((> n 5)) (pass-if n - (let ((cond (make-iterations-cond n))) - (while (cond))) - #t))) + (eval `(letrec ((make-iterations-cond + (lambda (n) + (lambda () + (cond ((not n) + (error "oops, condition re-tested after giving false")) + ((= 0 n) + (set! n #f) + #f) + (else + (set! n (1- n)) + #t)))))) + (let ((cond (make-iterations-cond ,n))) + (while (cond)) + #t)) + (interaction-environment))))) (pass-if "initially false" (while #f (unreachable)) #t) - (with-test-prefix "in empty environment" - - ;; an environment with no bindings at all - (define empty-environment - (make-module 1)) - - ;; these tests are 'unresolved because to work with ice-9 syncase it was - ;; necessary to drop the unquote from `do' in the implementation, and - ;; unfortunately that makes `while' depend on its evaluation environment - - (pass-if "empty body" - (throw 'unresolved) - (eval `(,while #f) - empty-environment) - #t) - - (pass-if "initially false" - (throw 'unresolved) - (eval `(,while #f - #f) - empty-environment) - #t) - - (pass-if "iterating" - (throw 'unresolved) - (let ((cond (make-iterations-cond 3))) - (eval `(,while (,cond) - 123 456) - empty-environment)) - #t)) - (with-test-prefix "iterations" (do ((n 0 (1+ n))) ((> n 5)) @@ -1063,8 +1037,9 @@ (with-test-prefix "break" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (break 1))) + (eval '(while #t + (break 1)) + (interaction-environment))) (with-test-prefix "from cond" (pass-if "first" @@ -1135,8 +1110,9 @@ (with-test-prefix "continue" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (continue 1))) + (eval '(while #t + (continue 1)) + (interaction-environment))) (with-test-prefix "from cond" (do ((n 0 (1+ n))) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index caace7fd4..6400d2dd8 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -21,6 +21,20 @@ :use-module (ice-9 threads) :use-module (test-suite lib)) +(define (asyncs-still-working?) + (let ((a #f)) + (system-async-mark (lambda () + (set! a #t))) + ;; The point of the following (equal? ...) is to go through + ;; primitive code (scm_equal_p) that includes a SCM_TICK call and + ;; hence gives system asyncs a chance to run. Of course the + ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the + ;; near future we may be using the VM instead of the traditional + ;; compiler, and then we will still want asyncs-still-working? to + ;; work. (The VM should probably have SCM_TICK calls too, but + ;; let's not rely on that here.) + (equal? '(a b c) '(a b c)) + a)) (if (provided? 'threads) (begin @@ -101,6 +115,9 @@ (with-test-prefix "n-for-each-par-map" + (pass-if "asyncs are still working 2" + (asyncs-still-working?)) + (pass-if "0 in limit 10" (n-for-each-par-map 10 noop noop '()) #t) @@ -143,12 +160,18 @@ (with-test-prefix "lock-mutex" + (pass-if "asyncs are still working 3" + (asyncs-still-working?)) + (pass-if "timed locking fails if timeout exceeded" (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (lock-mutex m (+ (current-time) 1))))) (not (join-thread t))))) + (pass-if "asyncs are still working 6" + (asyncs-still-working?)) + (pass-if "timed locking succeeds if mutex unlocked within timeout" (let* ((m (make-mutex)) (c (make-condition-variable)) @@ -164,7 +187,12 @@ (unlock-mutex cm) (sleep 1) (unlock-mutex m) - (join-thread t))))) + (join-thread t)))) + + (pass-if "asyncs are still working 7" + (asyncs-still-working?)) + + ) ;; ;; timed mutex unlocking @@ -172,12 +200,18 @@ (with-test-prefix "unlock-mutex" + (pass-if "asyncs are still working 5" + (asyncs-still-working?)) + (pass-if "timed unlocking returns #f if timeout exceeded" (let ((m (make-mutex)) (c (make-condition-variable))) (lock-mutex m) (not (unlock-mutex m c (current-time))))) + (pass-if "asyncs are still working 4" + (asyncs-still-working?)) + (pass-if "timed unlocking returns #t if condition signaled" (let ((m1 (make-mutex)) (m2 (make-mutex)) @@ -226,7 +260,36 @@ (pass-if "timed joining succeeds if thread exits within timeout" (let ((t (begin-thread (begin (sleep 1) #t)))) - (join-thread t (+ (current-time) 2))))) + (join-thread t (+ (current-time) 2)))) + + (pass-if "asyncs are still working 1" + (asyncs-still-working?)) + + ;; scm_join_thread_timed has a SCM_TICK in the middle of it, + ;; to allow asyncs to run (including signal delivery). We + ;; used to have a bug whereby if the joined thread terminated + ;; at the same time as the joining thread is in this SCM_TICK, + ;; scm_join_thread_timed would not notice and would hang + ;; forever. So in this test we are setting up the following + ;; sequence of events. + ;; T=0 other thread is created and starts running + ;; T=2 main thread sets up an async that will sleep for 10 seconds + ;; T=2 main thread calls join-thread, which will... + ;; T=2 ...call the async, which starts sleeping + ;; T=5 other thread finishes its work and terminates + ;; T=7 async completes, main thread continues inside join-thread. + (pass-if "don't hang when joined thread terminates in SCM_TICK" + (let ((other-thread (make-thread sleep 5))) + (letrec ((delay-count 10) + (aproc (lambda () + (set! delay-count (- delay-count 1)) + (if (zero? delay-count) + (sleep 5) + (system-async-mark aproc))))) + (sleep 2) + (system-async-mark aproc) + (join-thread other-thread))) + #t)) ;; ;; thread cancellation diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test new file mode 100644 index 000000000..18b67d6c8 --- /dev/null +++ b/test-suite/tests/tree-il.test @@ -0,0 +1,467 @@ +;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- +;;;; Andy Wingo --- May 2009 +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 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 tree-il) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (system base pmatch) + #:use-module (language tree-il) + #:use-module (language glil)) + +;; Of course, the GLIL that is emitted depends on the source info of the +;; input. Here we're not concerned about that, so we strip source +;; information from the incoming tree-il. + +(define (strip-source x) + (post-order! (lambda (x) (set! (tree-il-src x) #f)) + x)) + +(define-syntax assert-scheme->glil + (syntax-rules () + ((_ in out) + (let ((tree-il (strip-source + (compile 'in #:from 'scheme #:to 'tree-il)))) + (pass-if 'in + (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) + 'out)))))) + +(define-syntax assert-tree-il->glil + (syntax-rules () + ((_ in out) + (pass-if 'in + (let ((tree-il (strip-source (parse-tree-il 'in)))) + (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) + 'out)))))) + +(define-syntax assert-tree-il->glil/pmatch + (syntax-rules () + ((_ in pat test ...) + (let ((exp 'in)) + (pass-if 'in + (let ((glil (unparse-glil + (compile (strip-source (parse-tree-il exp)) + #:from 'tree-il #:to 'glil)))) + (pmatch glil + (pat (guard test ...) #t) + (else #f)))))))) + +(with-test-prefix "void" + (assert-tree-il->glil + (void) + (program 0 0 0 0 () (void) (call return 1))) + (assert-tree-il->glil + (begin (void) (const 1)) + (program 0 0 0 0 () (const 1) (call return 1))) + (assert-tree-il->glil + (apply (primitive +) (void) (const 1)) + (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) + +(with-test-prefix "application" + (assert-tree-il->glil + (apply (toplevel foo) (const 1)) + (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) + (assert-tree-il->glil/pmatch + (begin (apply (toplevel foo) (const 1)) (void)) + (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) + (call drop 1) (branch br ,l2) + (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) (apply (toplevel bar))) + (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) + (call goto/args 1)))) + +(with-test-prefix "conditional" + (assert-tree-il->glil/pmatch + (if (const #t) (const 1) (const 2)) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (const 1) (call return 1) + (label ,l2) (const 2) (call return 1)) + (eq? l1 l2)) + + (assert-tree-il->glil/pmatch + (begin (if (const #t) (const 1) (const 2)) (const #f)) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) + (label ,l3) (label ,l4) (const #f) (call return 1)) + (eq? l1 l3) (eq? l2 l4)) + + (assert-tree-il->glil/pmatch + (apply (primitive null?) (if (const #t) (const 1) (const 2))) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (const 1) (branch br ,l2) + (label ,l3) (const 2) (label ,l4) + (call null? 1) (call return 1)) + (eq? l1 l3) (eq? l2 l4))) + +(with-test-prefix "primitive-ref" + (assert-tree-il->glil + (primitive +) + (program 0 0 0 0 () (toplevel ref +) (call return 1))) + + (assert-tree-il->glil + (begin (primitive +) (const #f)) + (program 0 0 0 0 () (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (primitive +)) + (program 0 0 0 0 () (toplevel ref +) (call null? 1) + (call return 1)))) + +(with-test-prefix "lexical refs" + (assert-tree-il->glil + (let (x) (y) ((const 1)) (lexical x y)) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (const #f) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (call null? 1) (call return 1) + (unbind)))) + +(with-test-prefix "lexical sets" + (assert-tree-il->glil + (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (void) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (const #f) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) + (apply (primitive null?) (set! (lexical x y) (const 2)))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (void) (call null? 1) (call return 1) + (unbind)))) + +(with-test-prefix "module refs" + (assert-tree-il->glil + (@ (foo) bar) + (program 0 0 0 0 () + (module public ref (foo) bar) + (call return 1))) + + (assert-tree-il->glil + (begin (@ (foo) bar) (const #f)) + (program 0 0 0 0 () + (module public ref (foo) bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (@ (foo) bar)) + (program 0 0 0 0 () + (module public ref (foo) bar) + (call null? 1) (call return 1))) + + (assert-tree-il->glil + (@@ (foo) bar) + (program 0 0 0 0 () + (module private ref (foo) bar) + (call return 1))) + + (assert-tree-il->glil + (begin (@@ (foo) bar) (const #f)) + (program 0 0 0 0 () + (module private ref (foo) bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (@@ (foo) bar)) + (program 0 0 0 0 () + (module private ref (foo) bar) + (call null? 1) (call return 1)))) + +(with-test-prefix "module sets" + (assert-tree-il->glil + (set! (@ (foo) bar) (const 2)) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (@ (foo) bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (@ (foo) bar) (const 2))) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (void) (call null? 1) (call return 1))) + + (assert-tree-il->glil + (set! (@@ (foo) bar) (const 2)) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (@@ (foo) bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel refs" + (assert-tree-il->glil + (toplevel bar) + (program 0 0 0 0 () + (toplevel ref bar) + (call return 1))) + + (assert-tree-il->glil + (begin (toplevel bar) (const #f)) + (program 0 0 0 0 () + (toplevel ref bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (toplevel bar)) + (program 0 0 0 0 () + (toplevel ref bar) + (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel sets" + (assert-tree-il->glil + (set! (toplevel bar) (const 2)) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (toplevel bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (toplevel bar) (const 2))) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel defines" + (assert-tree-il->glil + (define bar (const 2)) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (define bar (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (define bar (const 2))) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "constants" + (assert-tree-il->glil + (const 2) + (program 0 0 0 0 () + (const 2) (call return 1))) + + (assert-tree-il->glil + (begin (const 2) (const #f)) + (program 0 0 0 0 () + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (const 2)) + (program 0 0 0 0 () + (const 2) (call null? 1) (call return 1)))) + +(with-test-prefix "lambda" + (assert-tree-il->glil + (lambda (x) (y) () (const 2)) + (program 0 0 0 0 () + (program 1 0 0 0 () + (bind (x local 0)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x x1) (y y1) () (const 2)) + (program 0 0 0 0 () + (program 2 0 0 0 () + (bind (x local 0) (x1 local 1)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda x y () (const 2)) + (program 0 0 0 0 () + (program 1 1 0 0 () + (bind (x local 0)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (const 2)) + (program 0 0 0 0 () + (program 2 1 0 0 () + (bind (x local 0) (x1 local 1)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (lexical x y)) + (program 0 0 0 0 () + (program 2 1 0 0 () + (bind (x local 0) (x1 local 1)) + (local ref 0) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (lexical x1 y1)) + (program 0 0 0 0 () + (program 2 1 0 0 () + (bind (x local 0) (x1 local 1)) + (local ref 1) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) + (program 0 0 0 0 () + (program 1 0 0 1 () + (bind (x external 0)) + (local ref 0) (external set 0 0) + (program 1 0 0 0 () + (bind (y local 0)) + (external ref 1 0) (call return 1)) + (call return 1)) + (call return 1)))) + +(with-test-prefix "sequence" + (assert-tree-il->glil + (begin (begin (const 2) (const #f)) (const #t)) + (program 0 0 0 0 () + (const #t) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (begin (const #f) (const 2))) + (program 0 0 0 0 () + (const 2) (call null? 1) (call return 1)))) + +;; FIXME: binding info for or-hacked locals might bork the disassembler, +;; and could be tightened in any case +(with-test-prefix "the or hack" + (assert-tree-il->glil/pmatch + (let (x) (y) ((const 1)) + (if (lexical x y) + (lexical x y) + (let (a) (b) ((const 2)) + (lexical a b)))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (branch br-if-not ,l1) + (local ref 0) (call return 1) + (label ,l2) + (const 2) (bind (a local 0)) (local set 0) + (local ref 0) (call return 1) + (unbind) + (unbind)) + (eq? l1 l2)) + + (assert-tree-il->glil/pmatch + (let (x) (y) ((const 1)) + (if (lexical x y) + (lexical x y) + (let (a) (b) ((const 2)) + (lexical x y)))) + (program 0 0 2 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (branch br-if-not ,l1) + (local ref 0) (call return 1) + (label ,l2) + (const 2) (bind (a local 1)) (local set 1) + (local ref 0) (call return 1) + (unbind) + (unbind)) + (eq? l1 l2))) + +(with-test-prefix "apply" + (assert-tree-il->glil + (apply (primitive @apply) (toplevel foo) (toplevel bar)) + (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) + (assert-tree-il->glil/pmatch + (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) + (program 0 0 0 0 () + (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) + (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) + (program 0 0 0 0 () + (toplevel ref foo) + (toplevel ref bar) (toplevel ref baz) (call apply 2) + (call goto/args 1)))) + +(with-test-prefix "call/cc" + (assert-tree-il->glil + (apply (primitive @call-with-current-continuation) (toplevel foo)) + (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1))) + (assert-tree-il->glil/pmatch + (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) + (program 0 0 0 0 () + (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) + (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) + (apply (toplevel @call-with-current-continuation) (toplevel bar))) + (program 0 0 0 0 () + (toplevel ref foo) + (toplevel ref bar) (call call/cc 1) + (call goto/args 1)))) + diff --git a/testsuite/t-match.scm b/testsuite/t-match.scm index 4b85f30d3..ed56ae7ef 100644 --- a/testsuite/t-match.scm +++ b/testsuite/t-match.scm @@ -12,7 +12,7 @@ (define (matches? obj) ; (format #t "matches? ~a~%" obj) (match obj - (($ stuff) => #t) + (($ stuff) #t) ; (blurps #t) ("hello" #t) (else #f)))