From 02f07e2b43d10a3c879505ceaf96bd34166d79ba Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 10:33:09 +0000 Subject: [PATCH 01/81] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index a3e00ee53..8700c947f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -13,6 +13,11 @@ from `AC_CONFIG_FILES' and `AC_CONFIG_COMMANDS'. * check-guile.in (top_builddir): Fix bug: Use cwd. + (TEST_SUITE_DIR): Fix bug: Use `top_srcdir'. + (GUILE_LOAD_PATH): No longer include $top_srcdir. + + * pre-inst-guile: Fix bug: Use ":" in `case' pattern to prevent + prefix aliasing. 2002-01-31 Stefan Jahn From ebc5d94c15686a2836fcc44bc76ff00b8a86f042 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 20:53:50 +0000 Subject: [PATCH 02/81] (Questions): Add q/a on cvs branch sanity. --- ANON-CVS | 106 ------------------------------------------------------- 1 file changed, 106 deletions(-) diff --git a/ANON-CVS b/ANON-CVS index cda379630..e69de29bb 100644 --- a/ANON-CVS +++ b/ANON-CVS @@ -1,106 +0,0 @@ -Anonymous CVS access to Guile ======================================== - -We make the current Guile sources available via anonymous CVS. Please -keep in mind that these sources are strictly experimental; they will -usually not be well-tested, and may not even compile on some systems. -They may contain interfaces which will change. They will usually not -be of sufficient quality for use by people not comfortable hacking the -innards of Guile. Caveat! - -However, we're providing them anyway for several reasons. We'd like -to encourage people to get involved in developing Guile. People -willing to use the bleeding edge of development can get earlier access -to new, experimental features. Patches submitted relative to recent -sources will be easier for us to evaluate and install, since the -patch's original sources will be closer to what we're working with. -And it allows us to start testing features earlier. - -Since the CVS tree is arranged for the convenience of the developers, -it requires GCC and GNU Make, which together support automatic -dependency management. You will also need to install autoconf, -automake, and libtool; the recommended versions are listed in HACKING. - -To check out a CVS working directory: - -1) Install CVS version 1.9 or later on your system. - -2) Log into the CVS server: - - $ cvs -d :pserver:anoncvs@subversions.gnu.org:/cvs login - - At the prompt for `CVS password:', simply press the enter key. - Once you have logged in, your password is saved in ~/.cvspass, and you - will not need to enter it again. - -3) Check out a module: - - $ cvs -z 9 -d :pserver:anoncvs@subversions.gnu.org:/cvs checkout guile-core - - This should create a new directory `guile-core' in your current - directory, and populate it with the current Guile sources. - - To check out all modules use: - - $ cvs -z 9 -d :pserver:anoncvs@subversions.gnu.org:/cvs checkout guile - -4) In the top directory of the source tree, run the command `./autogen.sh'. - This builds the configure script, Makefile.in, and other derived files - used by the build system. - -The modules available for checkout include: - - guile-core --- The scheme interpreter itself. - guile-tcltk --- An interface between Guile and Tcl/Tk. - guile-scsh --- An incomplete port of scsh to Guile. - guile-rgx-ctax --- This has been discontinued; use Andrew Archibald's - distribution instead: - ftp://ftp.red-bean.com/pub/guile/contrib/misc/guile-lang-allover-0.1.tar.gz - -Once you have a working directory, you can bring it up to date easily -and efficiently: - -1) Go to the top directory of the source tree. That is, your current - directory should be the one containing `configure.in', `README', - and so on. - -2) Do the update: - $ cvs update - -This will incorporate any changes the developers have made to Guile -since your last update into your source tree. - - -Change Notification ================================================== - -If you would like to receive mail when people commit changes to the -Guile CVS repository, you can subscribe to guile-cvs@gnu.org by using -the Mailman mailing list interface at - - - - -Questions ============================================================ - -(I don't know if they'll be "frequently asked" or not yet!) - -- It takes forever to do an update; what can I do to speed it up? - - CVS tries to be smart about what it sends; it will transmit and - install only those files that have changed, and will sometimes - transmit and apply patches instead, to save transmission time. - - It is also possible to have CVS compress transmitted data, using zlib. - Put the following line in your ~/.cvsrc file: - - cvs -z 9 - - See the CVS documentation for more details. - - -- What happens if I've changed files in my working directory, and then - I do an update? - - If you have made local changes to your sources, the `cvs update' - command will not overwrite them; instead, CVS will try to merge its - changes with your changes, as if you had applied a patch. Rejects are - marked in the sources. From 0458b202696639e45f46ad9cb27e1da286a6baf3 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 6 Feb 2002 23:00:37 +0000 Subject: [PATCH 03/81] (12): New. --- BUGS | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) diff --git a/BUGS b/BUGS index 20c531d6f..d3a2ecb32 100644 --- a/BUGS +++ b/BUGS @@ -279,5 +279,68 @@ mvo sez: > optargs) offers, yo are probably best off writing your own argument > parser. + +bug 12 -- goops class redefinition not signalling "no such accessor" error +reported-by: wawrzin@cs.tu-berlin.de / 2001-12-04 +fixed: not-yet + +Thomas Wawrzinek sez: +> Running the following script produces some guile output which confueses me: +> +> ;;; script.scm +> (use-modules (oop goops)) +> +> (define-class ()) +> +> (define-class () +> (a #:init-value #f #:accessor a-value #:init-keyword #:a-value) +> (b #:init-value #f #:accessor b-value #:init-keyword #:b-value)) +> +> (define-class ()) +> +> (define-method (initialize (o ) . args) +> (set! (a-value o) "BAR") +> (next-method)) +> +> (define-generic print) +> +> (define-method (print (o )) +> (display (a-value o)) (newline) +> (display (b-value o)) (newline)) +> +> ;;; OK, this is very *wrong*! +> (define-class ()) +> +> (define baz (make #:b-value "BAZ")) +> +> (print baz) +> +> $ guile -s script.scm +> BAR +> # +> $ guile -v +> Guile 1.5.4 +> Copyright (c) 1995, 1996, 1997, 2000, 2001 Free Software Foundation +> Guile may be distributed under the terms of the GNU General Public Licence; +> certain other uses are permitted as well. For details, see the file +> `COPYING', which is included in the Guile distribution. +> There is no warranty, to the extent permitted by law. +> +> I'm running on a SuSE Linux 7.2 box ... +> +> I expected that because of the second (define-class ...) I would get +> some sensible error message (at least about the usage of (a-value ...) in +> the (print ...) generic function call). +> +> Maybe I'm mistaken here, I know that GOOPS has a class redefinition +> protocol, but does it go with the define-class macro? +> +> I accidently had such a second (define-class ...) with an already +> used class-name. In a much more complex program than the above, this +> resulted in a segmentation fault (backtrace told me it was GC related). +> +> To avoid such behavior, would it be sensible to have guile indicate +> a wrong usage error or something? + [BUGS ends here] From 4dcf4449da5054b60961c9f6312a07670ed9ad8c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 7 Feb 2002 14:57:58 +0000 Subject: [PATCH 04/81] (EXTRA_DIST): Added pre-inst-guile and pre-inst-guile.am. --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index ea26d8692..99206df0c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -30,7 +30,7 @@ include_HEADERS = libguile.h # automake sometimes forgets to distribute acconfig.h, # apparently depending on the phase of the moon. EXTRA_DIST = qthreads.m4 HACKING GUILE-VERSION ANON-CVS SNAPSHOTS TODO \ - $(ACLOCAL) acconfig.h BUGS + $(ACLOCAL) acconfig.h BUGS pre-inst-guile pre-inst-guile.am TESTS = check-guile From f660f92e3c84f9fa34da90e31a6f41a6e04f10ba Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 7 Feb 2002 15:14:15 +0000 Subject: [PATCH 05/81] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 8700c947f..43498cb31 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2002-02-07 Marius Vollmer + + * Makefile.am (EXTRA_DIST): Added pre-inst-guile and + pre-inst-guile.am. + 2002-02-05 Thien-Thi Nguyen * pre-inst-guile.am, pre-inst-guile: New files. From 87fefc1cbe5fb42b62f30697758ff27372bce293 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 8 Feb 2002 03:18:38 +0000 Subject: [PATCH 06/81] Add commentary; nfc. --- ice-9/regex.scm | 40 ++++++++++++++++++++++++++++++---------- 1 file changed, 30 insertions(+), 10 deletions(-) diff --git a/ice-9/regex.scm b/ice-9/regex.scm index fb4a93e58..97eb0110b 100644 --- a/ice-9/regex.scm +++ b/ice-9/regex.scm @@ -1,15 +1,15 @@ ;;;; Copyright (C) 1997, 1999, 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 software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -38,7 +38,27 @@ ;;;; 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. -;;;; +;;;; + +;;; Commentary: + +;; These procedures are exported: +;; (match:count match) +;; (match:string match) +;; (match:prefix match) +;; (match:suffix match) +;; (regexp-match? match) +;; (regexp-quote string) +;; (match:start match . submatch-num) +;; (match:end match . submatch-num) +;; (match:substring match . submatch-num) +;; (string-match pattern str . start) +;; (regexp-substitute port match . items) +;; (fold-matches regexp string init proc . flags) +;; (list-matches regexp string . flags) +;; (regexp-substitute/global port regexp string . items) + +;;; Code: ;;;; POSIX regex support functions. @@ -83,16 +103,16 @@ (loop (+ 1 i))) (else #f))))) -(define (regexp-quote regexp) +(define (regexp-quote string) (call-with-output-string (lambda (p) (let loop ((i 0)) - (and (< i (string-length regexp)) + (and (< i (string-length string)) (begin - (case (string-ref regexp i) + (case (string-ref string i) ((#\* #\. #\( #\) #\+ #\? #\\ #\^ #\$ #\{ #\}) (write-char #\\ p))) - (write-char (string-ref regexp i) p) + (write-char (string-ref string i) p) (loop (1+ i)))))))) (define (match:start match . args) @@ -197,13 +217,13 @@ ;; for-each, because we need to make sure 'post at the ;; end of the item list is a tail call. (let next-item ((items items)) - + (define (do-item item) (cond ((string? item) (display item port)) ((integer? item) (display (match:substring m item) port)) ((procedure? item) (display (item m) port)) - ((eq? item 'pre) + ((eq? item 'pre) (display (substring string start (match:start m)) port)) From 90d4a6b0163cba40c52854cc5bc986dd34cb9de6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 8 Feb 2002 03:19:33 +0000 Subject: [PATCH 07/81] *** empty log message *** --- ice-9/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 542d0aa67..d8c81c5a9 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,7 @@ +2002-02-07 Thien-Thi Nguyen + + * regex.scm: Add commentary; nfc. + 2002-02-05 Thien-Thi Nguyen * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. From 1f761e0a5941b4743199d57e885026cc02badf35 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 8 Feb 2002 10:50:36 +0000 Subject: [PATCH 08/81] Initial revision --- devel/modules/design-notes.texi | 295 ++++++++++++++++++++++++++++++++ 1 file changed, 295 insertions(+) create mode 100644 devel/modules/design-notes.texi diff --git a/devel/modules/design-notes.texi b/devel/modules/design-notes.texi new file mode 100644 index 000000000..a8853e594 --- /dev/null +++ b/devel/modules/design-notes.texi @@ -0,0 +1,295 @@ +@c devel/modules/desgin-notes.texi + +@c TODO +@c - distill wishlist, index +@c - in Findings, characterize current module system wrt wishlist + +@node Module System Design Notes +@chapter Module System Design Notes + +This chapter documents module system design history. At the moment +(guile-1.5.4, 2002-02-08), the module system is supposedly undergoing +redesign; the provisional implementation works but has problems, notably +making compilation difficult. + +Because module systems design is (was?) an area of active research and +development in the Scheme community, many different features are possible. +This section is a historical record of the selection process used by the Guile +hackers (if one can be discerned). + +@menu +* Wishlist:: +* Findings:: +* Selection Criteria:: +* Rationale Statements:: +* Specification:: +@end menu + +@node Wishlist +@subsection Wishlist + +In the guile-related mailing lists of yore, discussion resulted in the +following desirable traits. Note that some of these contradict each other. + +@itemize @bullet + +@item +support separate compilation + +@item +hierarchical module names + +@item +support relative references within the module name space (so that a +module within a package can use a sibling module without knowing the +prefix of the module name) + +@item +support re-use of code (the same implementation can be presented to +the world through several interfaces) + +@item +support individual and group renaming of bindings when using other +modules + +@item +easy to import and re-export entire interfaces (so that a main +interface in a package can function as a "relay" and publish +bindings from many modules in the package) + +@item +support both variable and syntactic bindings (these should be +clearly separated, though) and mesh well with hygienic macro +systems + +@item +hygienic implies that we shouldn't need to care to export bindings +which an exported macro introduces at the point of its use + +@item +autoloading + +@item +unmemoization protocol + +@item +cleanliness + +A module should be able to be totally clean. There should be no +need to have *any* extra bindings in a module (a la +%module-interface or `define-module'). + +Therefore, we should have at least one dedicated "command" or +"config" or "repl" module. + +It would probably be a good idea to follow other good Scheme +interpreters' lead and introduce the , syntax for walking +around modules, inspecting things, entering the debugger, etc. +Such commands can be looked up in this repl module. + +If we insist on not using , syntax, we are forced to let +the module use list consist of a "sticky" part and the rest, where +the "sticky" part is only available at the repl prompt and not to +the code within the module, and which follows us when we walk around +in the system. + +@item +well integrated with the translator framework + +We should be able to say that a module uses a different syntax or +language. + +Note here the nice config language of the Scheme48 module system +where it is possible to separate code from module specification: the +module specification can use scheme syntax and rest in one file, +while the module itself can use the syntax of another language. + +This config language also supports re-use of code in a neat way. + +@item +examine connection with object system: how easy is it to support +Java and other class-centered object systems? + +@item +easy to export the same module under several different names + +@item +easily supports both compiled and interpreted modules + +@item +compiled modules can by dynamically loaded or statically linked in +(libltdl might provide this automatically) + +@item +convenient syntax for referencing bindings in modules that are +loaded but not used + +(Assuming this distinction exists.) But maybe group renaming is a better +solution to a similar class of problems. + +@item +ability to unuse a module (and have it get collected when there are +no more references) + +@item +orthoganality between source files, directories and modules. i.e. ability to +have multiple modules in one source file and/or multiple source files in one +module + +@item +backward compatibility + +@item +whenever possible the module's meta-information should be stored +within the module itself (only possible for scheme files) + +@item +the compiler stores the meta-information into a single file and updates it +accordingly + +(FIXME: per module, per package, directory?, per project?) This +meta-information should still be human readable (Sun's EJB use XML for their +deployment descriptors). + +@item +use the file system as module repository + +Since guile is a GNU project we can expect a GNU (or Unix) environment. That +means that we should use the file system as the module repository. (This +would help us avoid modules pointing to files which are pointing to other +files telling the user "hey, that's me (the module) over there".) + +@item +every module has exactly @emph{one} owner who is responsible for the +module @emph{and} its interface (this contradicts with the "more than one +interface" concept) + +@item +support module collections + +Provide "packages" with a package scope for people working together on a +project. In some sense a module is a view on the underlying package. + +@item +ability to request (i.e. import or access) complete packages + +@item +support module "generations" (or "versions") + +Whenever a new module fails to handle a request (due to an error) it will be +replaced by the old version. + +@item +help the user to handle exceptions (note: exceptions +are not errors, see above) + +@item +no special configuration language (like @code{,in} etc.) + +You can always press Control-D to terminate the module's repl and return to +the config module. + +@item +both C and Scheme level interfaces + +@item +programming interface to module system primitives + +One should be able to make customized module systems from the low-level +interface, as an alternative to using the default module system. The +default module system should use the same low-level procedures. + +@item +Here are some features Keisuke Nishida desires to support his VM/compiler +[snarfed directly from post dated 2001-02-06, +and requires formatting]: + + * There is no "current module". + + * Module variables are globally identified by an identifier + like "system::core::car". + + * Bindings are solved syntactically, either by a translator + or a compiler. If you write just "car", it is expanded to + "system::core::car" by a translator or compiler, depending + on what modules you use. + + * An interpreter (repl) may memorize the "current working module". + It tells the translator or the compiler what modules should be + used to identify a variable. So, during interactive sessions, + a user may feel as if there *is* the current module. + + * But the fact is, all variables are globally identified at + syntax level. Therefore, the compiler can identify all + variables at compile time. This means the following code + is not allowed: + + ;; I want to access `foo' in the module named some-module-name + (let ((module (lookup-module some-module-name))) + (set! (current-module) module) + (foo x)) + -> ERROR: Unbound variable: current-module + + (let ((module (lookup-module some-module-name))) + (module::foo x)) + -> ERROR: There is no variable named "module::foo" + + Instead, you should write as follows if you need a dynamic access: + + (let ((module (lookup-module some-module-name))) + ((module-ref module 'foo) x)) + + (let ((module (lookup-module some-module-name))) + ((module 'foo) x)) ;; if module is an applicable smob + +@end itemize + +@c $Date: 2002-02-08 10:50:36 $ +@node Findings +@subsection Findings + +This section briefly describes module system truths that are one step more +detailed than "module systems are hairy". These truths are not self-evident; +we rely on research, active experimentation and lots of discussion. The goal +of this section is to save ourselves from rehashing that which was hashed +previously. + +@itemize @bullet + +@item Kent Dybvig's module system + +A paper is available at +@uref{http://www.cs.indiana.edu/~dyb/papers/popl99.ps.gz, + http://www.cs.indiana.edu/~dyb/papers/popl99.ps.gz}. + +This was discussed in 2000-11 and 2000-12. + +@item Distinction between Top-Level Environment and Module + +These two are different beasts! Each of the following needs to be +well-defined with respect to both of these concepts: @code{eval}, +@code{define}, @code{define-public}, @code{define-module}, @code{load}, +working from REPL, top-level @code{begin}, [add here]. + +In guile-1.4, the distinction was not clear. + +@item Current module system internals + +@xref{Top,Module Internals,,module-snippets}, for implemetation +details of the module system up to and including guile-1.6.x. + +@item [add here] + +@end itemize + +@node Selection Criteria +@subsection Selection Criteria + +@node Rationale Statements +@subsection Rationale Statements + +@node Specification +@subsection Specification + + +@c devel/modules/desgin-notes.texi ends here From e79236a948466c0bc62aaa6c1d6118ee34373669 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 8 Feb 2002 11:50:51 +0000 Subject: [PATCH 09/81] * Complete Elisp translator work. --- lang/elisp/ChangeLog | 82 +++++++++++++++++++ lang/elisp/README | 72 +++++++---------- lang/elisp/STATUS | 35 ++++++++ lang/elisp/base.scm | 16 ++-- lang/elisp/example.el | 29 +++++++ lang/elisp/interface.scm | 8 +- lang/elisp/internals/lambda.scm | 46 +++++------ lang/elisp/internals/null.scm | 14 +++- lang/elisp/primitives/features.scm | 3 +- lang/elisp/primitives/fns.scm | 6 +- lang/elisp/primitives/lists.scm | 29 +++---- lang/elisp/primitives/load.scm | 2 +- lang/elisp/primitives/match.scm | 2 +- lang/elisp/primitives/numbers.scm | 7 +- lang/elisp/primitives/pure.scm | 2 +- lang/elisp/primitives/strings.scm | 5 +- lang/elisp/primitives/symprop.scm | 12 +-- lang/elisp/primitives/syntax.scm | 118 ++++++++++++++------------- lang/elisp/transform.scm | 125 ++++++++++++++++------------- 19 files changed, 385 insertions(+), 228 deletions(-) create mode 100644 lang/elisp/STATUS diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index d20d6e355..c30491159 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,85 @@ +2002-02-08 Neil Jerram + + * STATUS: New file. + + * README: Updated. + + * interface.scm (translate-elisp): New exported procedure. + (elisp-function): Symbol var is `obj', not `symbol'. + + * internals/lambda.scm, primitives/fns.scm: Fix confusion between + interactive-spec and interactive-specification. + + * internals/lambda.scm (transform-lambda), primitives/syntax.scm + (defmacro): Bind unspecified optional and rest arguments to #nil, + not #f. + + * internals/null.scm (->nil, lambda->nil): New, exported. + (null): Use ->nil. + + * primitives/features.scm (featurep), primitives/fns.scm + (fboundp, subrp): Use ->nil. + + * internals/lists.scm (cons, setcdr, memq, member, assq, assoc): + Simplified. + (car, cdr): Return #nil rather than #f. + + * primitives/load.scm (current-load-list), primitives/pure.scm + (purify-flag): Set to #nil, not #f. + + * primitives/match.scm (string-match): Return #nil rather than #f. + + * primitives/numbers.scm (integerp, numberp), + primitives/strings.scm (string-lessp, stringp): Use lambda->nil. + + * primitives/symprop.scm (boundp): Use ->nil. + (symbolp, local-variable-if-set-p): Return #nil rather than #f. + + * primitives/syntax.scm (prog1, prog2): Mangle variable names + further to lessen possibility of conflicts. + (if, and, or, cond): Return #nil rather than #f. + (cond): Return #t rather than t (which is undefined). + (let, let*): Bind uninitialized variables to #nil, not #f. + + * transform.scm: Resolve inconsistency in usage of `map', and add + an explanatory note. Also cleaned up use of subsidiary + transformation functions. Also use cons-source wherever possible. + (transform-datum, transform-quote): New. + (transform-quasiquote): Renamed from `transform-inside-qq'. + (transform-application): Apply `transform-quote' to application + args. + (cars->nil): Removed. + + * internals/null.scm (null), primitives/lists.scm (cons, car, cdr, + setcdr, memq, member, assq, assoc, nth): Update to take into + account new libguile support for Elisp nil value. + +2002-02-06 Neil Jerram + + * example.el (time): New macro, for performance measurement. + Accompanying comment compares results for Guile and Emacs. + + * transform.scm (scheme): New macro. + (transformer): New implementation of `scheme' escape that doesn't + rely on (lang elisp base) importing Guile bindings. + + * base.scm: No longer import anything from (guile). + (load-emacs): Add scheme form to ensure that keywords + read option is set correctly. + + * primitives/syntax.scm (defmacro, let, let*): Unquote uses of + `@bind' in transformed code. + (if): Unquote uses of `nil-cond' in transformed code. + + * internals/lambda.scm (transform-lambda): Unquote use of `@bind' + in transformed code. + + * transform.scm (transformer-macro): Don't quote `list' in + transformed code. + (transform-application): Don't quote `@fop' in transformed code. + (transformer): No need to treat `@bind' and `@fop' as special + cases in input to the transformer. + 2002-02-04 Neil Jerram * primitives/syntax.scm (parse-formals, transform-lambda, diff --git a/lang/elisp/README b/lang/elisp/README index f9218a0c8..1cecb381f 100644 --- a/lang/elisp/README +++ b/lang/elisp/README @@ -45,8 +45,7 @@ and try to bootstrap a complete Emacs environment: * Status -Please note that this is work in progress; the translator is -incomplete and not yet widely tested. +Please see the STATUS file for the full position. ** Trying to load a complete Emacs environment. @@ -163,12 +162,23 @@ transform Elisp variable references after all. *** Truth value stuff -Lots of stuff to do with providing the special self-evaluating `nil' -and `t' symbols, and macros that convert between Scheme and Elisp -truth values, and so on. +Following extensive discussions on the Guile mailing list between +September 2001 and January 2002, we decided to go with Jim Blandy's +proposal. See devel/translation/lisp-and-scheme.text for details. -I'm hoping that most of this will go away, but I need to show that -it's feasible first. +- The Elisp nil value is a new immediate SCM_MAKIFLAG, eq?-distinct +from both #f and '() (and of course any other Scheme value). It can +be accessed via the (guile) binding `%nil', and prints as `#nil'. + +- All Elisp primitives treat #nil, #f and '() as identical. + +- Scheme truth-testing primitives have been modified so that they +treat #nil the same as #f. + +- Scheme list-manipulating primitives have been modified so that they +treat #nil the same as '(). + +- The Elisp t value is the same as #t. ** Emacs editing primitives @@ -191,8 +201,9 @@ that Ken Raeburn has been doing on the Emacs codebase. Elisp is close enough to Scheme that it's convenient to coopt the existing Guile reader rather than to write a new one from scratch, but -there are a few syntactic differences that will require adding Elisp -support to the reader. +there are a few syntactic differences that will require changes in +reading and printing. None of the following changes has yet been +implemented. - Character syntax is `?a' rather than `#\a'. (Not done. More precisely, `?a' in Elisp isn't character syntax but an alternative @@ -204,12 +215,10 @@ support to the reader. and so on.) -- `nil' and `t' should be read (I think) as #f and #t. (Done.) +- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'. -- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'. (Not done.) - -Correspondingly, when printing, #f and '() should be written as -`nil'. (Not done.) +- When in an Elisp environment, #nil and #t should print as `nil' and + `t'. ** The Elisp evaluation module (lang elisp base) @@ -272,36 +281,6 @@ worry about adding unexec support to Guile!) For the output that currently results from calling `(load-emacs)', see above in the Status section. -* nil, #f and '() - -For Jim Blandy's notes on this, see the reference at the bottom of -this file. Currently I'm investigating a different approach, which is -better IMO than Jim's proposal because it avoids requiring multiple -false values in the Scheme world. - -According to my approach... - -- `nil' and `t' are read (when in Elisp mode) as #f and #t. - -- `(if x ...)', `(while x ...)' etc. are translated to something - like `(if (and x (not (null? x))) ...)'. - -- Functions which interpret an argument as a list -- - `cons', `setcdr', `memq', etc. -- either convert #f to '(), or - handle the #f case specially. - -- `eq' treats #f and '() as the same. - -- Optionally, functions which produce '() values -- i.e. the reader - and `cdr' -- could convert those immediately to #f. This shouldn't - affect the validity of any Elisp code, but it alters the balance of - #f and '() values swimming around in that code and so affects what - happens if two such values are returned to the Scheme world and then - compared. However, since you can never completely solve this - problem (unless you are prepared to convert arbitrarily deep - structures on entry to the Elisp world, which would kill performance), - I'm inclined not to try to solve it at all. - * Resources ** Ken Raeburn's Guile Emacs page @@ -316,6 +295,9 @@ http://gemacs.sourceforge.net http://sanpietro.red-bean.com/guile/guile/old/3114.html +Also now stored as guile-core/devel/translation/lisp-and-scheme.text +in Guile CVS. + ** Mikael Djurfeldt's notes on translation -See file guile-cvs/devel/translation/langtools.text in Guile CVS. +See file guile-core/devel/translation/langtools.text in Guile CVS. diff --git a/lang/elisp/STATUS b/lang/elisp/STATUS new file mode 100644 index 000000000..066e86f24 --- /dev/null +++ b/lang/elisp/STATUS @@ -0,0 +1,35 @@ + -*-text-*- + +I've now finished my currently planned work on the Emacs Lisp +translator in guile-core CVS. + +It works well enough for experimentation and playing around with -- +see the README file for details of what it _can_ do -- but has two +serious restrictions: + +- Most Emacs Lisp primitives are not yet implemented. In particular, + there are no buffer-related primitives. + +- Performance compares badly with Emacs. Using a handful of + completely unscientific tests, I found that Guile was between 2 and + 20 times slower than Emacs. (See the comment in + lang/elisp/example.el for details of tests and results.) + +Interestingly, both these restrictions point in the same direction: +the way forward is to define the primitives by compiling a +preprocessed version of the Emacs source code, not by trying to +implement them in Scheme. (Which, of course, is what Ken Raeburn's +project is already trying to do.) + +Given this conclusion, I expect that most of the translator's Scheme +code will eventually become obsolete, replaced by bits of Emacs C +code. Until then, though, it should have a role: + +- as a guide to the Guile Emacs project on how to interface to the + Elisp support in libguile (notably, usage of `@fop' and `@bind') + +- as a proof of concept and fun thing to experiment with + +- as a working translator that could help us develop our picture of + how we want to integrate translator usage in general with the rest + of Guile. diff --git a/lang/elisp/base.scm b/lang/elisp/base.scm index c4d2b8d9a..31bd759f7 100644 --- a/lang/elisp/base.scm +++ b/lang/elisp/base.scm @@ -1,13 +1,12 @@ (define-module (lang elisp base) - ;; Be pure. Nothing in this module requires most of the standard - ;; Guile builtins, and it creates a problem if this module has - ;; access to them, as @bind can dynamically change their values. + ;; Be pure. Nothing in this module requires symbols that map to the + ;; standard Guile builtins, and it creates a problem if this module + ;; has access to them, as @bind can dynamically change their values. + ;; Transformer output always uses the values of builtin procedures + ;; and macros directly. #:pure - ;; But we do need a few builtins - import them here. - #:use-module ((guile) #:select (@fop @bind nil-cond)) - ;; {Elisp Primitives} ;; ;; In other words, Scheme definitions of elisp primitives. This @@ -34,13 +33,10 @@ ;; Now switch into Emacs Lisp syntax. #:use-syntax (lang elisp transform)) -;(use-modules (lang elisp transform)) -;(read-set! keywords 'prefix) -;(set-module-transformer! (current-module) transformer) - ;;; Everything below here is written in Elisp. (defun load-emacs () + (scheme (read-set! keywords 'prefix)) (message "Calling loadup.el to clothe the bare Emacs...") (load "loadup.el") (message "Guile Emacs now fully clothed")) diff --git a/lang/elisp/example.el b/lang/elisp/example.el index 3379418ff..eebd2f88e 100644 --- a/lang/elisp/example.el +++ b/lang/elisp/example.el @@ -8,3 +8,32 @@ (apply 'concat contents) "\n" "\n")) + +(defmacro time (repeat-count &rest body) + `(let ((count ,repeat-count) + (beg (current-time)) + end) + (while (> count 0) + (setq count (- count 1)) + ,@body) + (setq end (current-time)) + (+ (* 1000000.0 (+ (* 65536.0 (- (car end) (car beg))) + (- (cadr end) (cadr beg)))) + (* 1.0 (- (caddr end) (caddr beg)))))) + +;Non-scientific performance measurements (Guile measurements are with +;`guile -q --no-debug'): +; +;(time 100000 (+ 3 4)) +; => 225,071 (Emacs) 4,000,000 (Guile) +;(time 100000 (lambda () 1)) +; => 2,410,456 (Emacs) 4,000,000 (Guile) +;(time 100000 (apply 'concat (mapcar (lambda (s) (concat s "." s)) '("a" "b" "c" "d")))) +; => 10,185,792 (Emacs) 136,000,000 (Guile) +;(defun sc (s) (concat s "." s)) +;(time 100000 (apply 'concat (mapcar 'sc '("a" "b" "c" "d")))) +; => 7,870,055 (Emacs) 26,700,000 (Guile) +; +;Sadly, it looks like the translator's performance sucks quite badly +;when compared with Emacs. But the translator is still very new, so +;there's probably plenty of room of improvement. diff --git a/lang/elisp/interface.scm b/lang/elisp/interface.scm index c71366acb..1e0758569 100644 --- a/lang/elisp/interface.scm +++ b/lang/elisp/interface.scm @@ -2,7 +2,9 @@ #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) #:use-module ((lang elisp internals load) #:select ((load . elisp:load))) + #:use-module ((lang elisp transform) #:select (transformer)) #:export (eval-elisp + translate-elisp elisp-function elisp-variable load-elisp-file @@ -19,6 +21,10 @@ "Evaluate the Elisp expression @var{x}." (eval x the-elisp-module)) +(define (translate-elisp x) + "Translate the Elisp expression @var{x} to equivalent Scheme code." + (transformer x)) + (define (elisp-function sym) "Return the procedure or macro that implements @var{sym} in Elisp. If @var{sym} has no Elisp function definition, return @code{#f}." @@ -112,7 +118,7 @@ exported to Elisp." (error "No macro name specified or deducible:" obj))) ((symbol? obj) (or name - (set! name symbol)) + (set! name obj)) (module-add! the-elisp-module name (module-ref (current-module) obj))) (else diff --git a/lang/elisp/internals/lambda.scm b/lang/elisp/internals/lambda.scm index 96b21f650..9917c08bd 100644 --- a/lang/elisp/internals/lambda.scm +++ b/lang/elisp/internals/lambda.scm @@ -67,28 +67,28 @@ `(((,> %--num-args ,(+ num-required num-optional)) (,error "Wrong number of args (too many args)")))) (else - (@bind ,(append (map (lambda (i) - (list (list-ref required i) - `(,list-ref %--args ,i))) - (iota num-required)) - (map (lambda (i) - (let ((i+nr (+ i num-required))) - (list (list-ref optional i) - `(,if (,> %--num-args ,i+nr) - (,list-ref %--args ,i+nr) - #f)))) - (iota num-optional)) - (if rest - (list (list rest - `(,if (,> %--num-args - ,(+ num-required - num-optional)) - (,list-tail %--args - ,(+ num-required - num-optional)) - '()))) - '())) - ,@(map transformer (cddr exp))))))))))) + (, @bind ,(append (map (lambda (i) + (list (list-ref required i) + `(,list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(,if (,> %--num-args ,i+nr) + (,list-ref %--args ,i+nr) + ,%nil)))) + (iota num-optional)) + (if rest + (list (list rest + `(,if (,> %--num-args + ,(+ num-required + num-optional)) + (,list-tail %--args + ,(+ num-required + num-optional)) + ,%nil))) + '())) + ,@(map transformer (cddr exp))))))))))) (define (set-not-subr! proc boolean) (set! (not-subr? proc) boolean)) @@ -101,7 +101,7 @@ (,set-procedure-property! %--lambda (,quote name) (,quote ,name)) (,set-not-subr! %--lambda #t) ,@(if is - `((,set! (,interactive-spec %--lambda) (,quote ,is))) + `((,set! (,interactive-specification %--lambda) (,quote ,is))) '()) %--lambda))) diff --git a/lang/elisp/internals/null.scm b/lang/elisp/internals/null.scm index 420278e0c..94e2b28dd 100644 --- a/lang/elisp/internals/null.scm +++ b/lang/elisp/internals/null.scm @@ -1,7 +1,13 @@ (define-module (lang elisp internals null) - #:export (null)) + #:export (->nil lambda->nil null)) + +(define (->nil x) + (or x %nil)) + +(define (lambda->nil proc) + (lambda args + (->nil (apply proc args)))) (define (null obj) - (or (not obj) - (null? obj) - (eq? obj 'nil))) ; Should be removed. + (->nil (or (not obj) + (null? obj)))) diff --git a/lang/elisp/primitives/features.scm b/lang/elisp/primitives/features.scm index 3d1e468ed..8cd1a9958 100644 --- a/lang/elisp/primitives/features.scm +++ b/lang/elisp/primitives/features.scm @@ -1,6 +1,7 @@ (define-module (lang elisp primitives features) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals load) + #:use-module (lang elisp internals null) #:use-module (ice-9 optargs)) (define-public features '()) @@ -12,7 +13,7 @@ (fset 'featurep (lambda (feature) - (memq feature features))) + (->nil (memq feature features)))) (fset 'require (lambda* (feature #:optional file-name noerror) diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm index ba2b53a79..f7a4aa003 100644 --- a/lang/elisp/primitives/fns.scm +++ b/lang/elisp/primitives/fns.scm @@ -18,11 +18,11 @@ (fset 'commandp (lambda (sym) - (if (interactive-spec (fref sym)) #t %nil))) + (if (interactive-specification (fref sym)) #t %nil))) (fset 'fboundp (lambda (sym) - (variable? (symbol-fref sym)))) + (->nil (variable? (symbol-fref sym))))) (fset 'symbol-function fref/error-if-void) @@ -30,7 +30,7 @@ (fset 'subrp (lambda (obj) - (not (not-subr? obj)))) + (->nil (not (not-subr? obj))))) (fset 'byte-code-function-p (lambda (object) diff --git a/lang/elisp/primitives/lists.scm b/lang/elisp/primitives/lists.scm index 43843f811..4907ed59d 100644 --- a/lang/elisp/primitives/lists.scm +++ b/lang/elisp/primitives/lists.scm @@ -3,9 +3,7 @@ #:use-module (lang elisp internals null) #:use-module (lang elisp internals signal)) -(fset 'cons - (lambda (x y) - (cons x (or y '())))) +(fset 'cons cons) (fset 'null null) @@ -14,13 +12,13 @@ (fset 'car (lambda (l) (if (null l) - #f + %nil (car l)))) (fset 'cdr (lambda (l) (if (null l) - #f + %nil (cdr l)))) (fset 'eq @@ -35,12 +33,7 @@ (fset 'setcar set-car!) -(fset 'setcdr - (lambda (cell newcdr) - (set-cdr! cell - (if (null newcdr) - '() - newcdr)))) +(fset 'setcdr set-cdr!) (for-each (lambda (sym proc) (fset sym @@ -48,14 +41,10 @@ (if (null list) %nil (if (null elt) - (or (proc #f list) - (proc '() list) - (proc %nil list) - (proc 'nil list)) ; 'nil shouldn't be - ; here, as it should - ; have been - ; translated by the - ; transformer. + (let loop ((l list)) + (cond ((null l) %nil) + ((null (car l)) l) + (else (loop (cdr l))))) (proc elt list)))))) '( memq member assq assoc) `(,memq ,member ,assq ,assoc)) @@ -97,7 +86,7 @@ (lambda (n list) (if (or (null list) (>= n (length list))) - #f + %nil (list-ref list n)))) (fset 'listp diff --git a/lang/elisp/primitives/load.scm b/lang/elisp/primitives/load.scm index 85915f1f7..a627b5d10 100644 --- a/lang/elisp/primitives/load.scm +++ b/lang/elisp/primitives/load.scm @@ -14,4 +14,4 @@ (lambda args #t)) -(define-public current-load-list #f) +(define-public current-load-list %nil) diff --git a/lang/elisp/primitives/match.scm b/lang/elisp/primitives/match.scm index 9b232c1ae..0a04ef5c5 100644 --- a/lang/elisp/primitives/match.scm +++ b/lang/elisp/primitives/match.scm @@ -45,7 +45,7 @@ (iota (match:count match)))) #f))) - (if last-match (car last-match) #f))) + (if last-match (car last-match) %nil))) (fset 'match-beginning (lambda (subexp) diff --git a/lang/elisp/primitives/numbers.scm b/lang/elisp/primitives/numbers.scm index dd72551dd..43246d32f 100644 --- a/lang/elisp/primitives/numbers.scm +++ b/lang/elisp/primitives/numbers.scm @@ -1,9 +1,10 @@ (define-module (lang elisp primitives numbers) - #:use-module (lang elisp internals fset)) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals null)) (fset 'logior logior) (fset 'logand logand) -(fset 'integerp integer?) +(fset 'integerp (lambda->nil integer?)) (fset '= =) (fset '< <) (fset '> >) @@ -39,4 +40,4 @@ (- shift 1)))))) lsh)) -(fset 'numberp number?) +(fset 'numberp (lambda->nil number?)) diff --git a/lang/elisp/primitives/pure.scm b/lang/elisp/primitives/pure.scm index 217550c53..7cb6b5317 100644 --- a/lang/elisp/primitives/pure.scm +++ b/lang/elisp/primitives/pure.scm @@ -5,4 +5,4 @@ (fset 'purecopy identity) -(define-public purify-flag #f) +(define-public purify-flag %nil) diff --git a/lang/elisp/primitives/strings.scm b/lang/elisp/primitives/strings.scm index 08bd8f8de..85a1c10a9 100644 --- a/lang/elisp/primitives/strings.scm +++ b/lang/elisp/primitives/strings.scm @@ -1,5 +1,6 @@ (define-module (lang elisp primitives strings) #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals null) #:use-module (lang elisp internals signal)) (fset 'substring substring) @@ -19,7 +20,7 @@ (fset 'number-to-string number->string) -(fset 'string-lessp stringnil stringinteger (string-ref array idx))) (else (wta 'arrayp array 1))))) -(fset 'stringp string?) +(fset 'stringp (lambda->nil string?)) (fset 'vector vector) diff --git a/lang/elisp/primitives/symprop.scm b/lang/elisp/primitives/symprop.scm index 4ca169226..a520a4b81 100644 --- a/lang/elisp/primitives/symprop.scm +++ b/lang/elisp/primitives/symprop.scm @@ -1,7 +1,8 @@ (define-module (lang elisp primitives symprop) - #:use-module (lang elisp internals set) - #:use-module (lang elisp internals fset) #:use-module (lang elisp internals evaluation) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals null) + #:use-module (lang elisp internals set) #:use-module (ice-9 optargs)) ;;; {Elisp Exports} @@ -16,7 +17,7 @@ (fset 'boundp (lambda (sym) - (module-defined? the-elisp-module sym))) + (->nil (module-defined? the-elisp-module sym)))) (fset 'default-boundp 'boundp) @@ -29,10 +30,11 @@ (fset 'symbolp (lambda (object) (or (symbol? object) - (keyword? object)))) + (keyword? object) + %nil))) (fset 'local-variable-if-set-p (lambda* (variable #:optional buffer) - #f)) + %nil)) (fset 'symbol-name symbol->string) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index 7f7e4af21..a597cd06a 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -32,7 +32,6 @@ `(,quote ,(cadr exp)) `(,begin (,if (,not (,defined? (,quote ,(cadr exp)))) ,(setq (list (car exp) (cadr exp) (caddr exp)) env)) - ;; (,macro-setq ,(cadr exp) ,(caddr exp))) (,quote ,(cadr exp))))))) (fset 'defconst @@ -87,28 +86,28 @@ `(((,> %--num-args ,(+ num-required num-optional)) (,error "Wrong number of args (too many args)")))) (else (,transformer - (@bind ,(append (map (lambda (i) - (list (list-ref required i) - `(,list-ref %--args ,i))) - (iota num-required)) - (map (lambda (i) - (let ((i+nr (+ i num-required))) - (list (list-ref optional i) - `(,if (,> %--num-args ,i+nr) - (,list-ref %--args ,i+nr) - #f)))) - (iota num-optional)) - (if rest - (list (list rest - `(,if (,> %--num-args - ,(+ num-required - num-optional)) - (,list-tail %--args - ,(+ num-required - num-optional)) - '()))) - '())) - ,@(map transformer (cdddr exp))))))))))))))))) + (, @bind ,(append (map (lambda (i) + (list (list-ref required i) + `(,list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(,if (,> %--num-args ,i+nr) + (,list-ref %--args ,i+nr) + ,%nil)))) + (iota num-optional)) + (if rest + (list (list rest + `(,if (,> %--num-args + ,(+ num-required + num-optional)) + (,list-tail %--args + ,(+ num-required + num-optional)) + ,%nil))) + '())) + ,@(map transformer (cdddr exp))))))))))))))))) ;;; {Sequencing} @@ -120,36 +119,34 @@ (fset 'prog1 (procedure->memoizing-macro (lambda (exp env) - `(,let ((%res1 ,(transformer (cadr exp)))) + `(,let ((%--res1 ,(transformer (cadr exp)))) ,@(map transformer (cddr exp)) - %res1)))) + %--res1)))) (fset 'prog2 (procedure->memoizing-macro (lambda (exp env) `(,begin ,(transformer (cadr exp)) - (,let ((%res2 ,(transformer (caddr exp)))) + (,let ((%--res2 ,(transformer (caddr exp)))) ,@(map transformer (cdddr exp)) - %res2))))) + %--res2))))) ;;; {Conditionals} -(define <-- *unspecified*) - (fset 'if (procedure->memoizing-macro (lambda (exp env) (let ((else-case (cdddr exp))) (cond ((null? else-case) - `(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f)) + `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil)) ((null? (cdr else-case)) - `(nil-cond ,(transformer (cadr exp)) - ,(transformer (caddr exp)) - ,(transformer (car else-case)))) + `(,nil-cond ,(transformer (cadr exp)) + ,(transformer (caddr exp)) + ,(transformer (car else-case)))) (else - `(nil-cond ,(transformer (cadr exp)) - ,(transformer (caddr exp)) - (,begin ,@(map transformer else-case))))))))) + `(,nil-cond ,(transformer (cadr exp)) + ,(transformer (caddr exp)) + (,begin ,@(map transformer else-case))))))))) (fset 'and (procedure->memoizing-macro @@ -162,13 +159,26 @@ (if (null? (cdr args)) (list (transformer (car args))) (cons (list not (transformer (car args))) - (cons #f + (cons %nil (loop (cdr args)))))))))))) +;;; NIL-COND expressions have the form: +;;; +;;; (nil-cond COND VAL COND VAL ... ELSEVAL) +;;; +;;; The CONDs are evaluated in order until one of them returns true +;;; (in the Elisp sense, so not including empty lists). If a COND +;;; returns true, its corresponding VAL is evaluated and returned, +;;; except if that VAL is the unspecified value, in which case the +;;; result of evaluating the COND is returned. If none of the COND's +;;; returns true, ELSEVAL is evaluated and its value returned. + +(define <-- *unspecified*) + (fset 'or (procedure->memoizing-macro (lambda (exp env) - (cond ((null? (cdr exp)) #f) + (cond ((null? (cdr exp)) %nil) ((null? (cddr exp)) (transformer (cadr exp))) (else (cons nil-cond @@ -183,15 +193,15 @@ (procedure->memoizing-macro (lambda (exp env) (if (null? (cdr exp)) - #f + %nil (cons nil-cond (let loop ((clauses (cdr exp))) (if (null? clauses) - '(#f) + (list %nil) (let ((clause (car clauses))) (if (eq? (car clause) #t) - (cond ((null? (cdr clause)) '(t)) + (cond ((null? (cdr clause)) (list #t)) ((null? (cddr clause)) (list (transformer (cadr clause)))) (else `((,begin ,@(map transformer (cdr clause)))))) @@ -210,7 +220,7 @@ (,nil-cond ,(transformer (cadr exp)) (,begin ,@(map transformer (cddr exp)) (%--while)) - #f)))) + ,%nil)))) %--while))))) ;;; {Local binding} @@ -218,13 +228,13 @@ (fset 'let (procedure->memoizing-macro (lambda (exp env) - `(@bind ,(map (lambda (binding) - (trc 'let binding) - (if (pair? binding) - `(,(car binding) ,(transformer (cadr binding))) - `(,binding #f))) - (cadr exp)) - ,@(map transformer (cddr exp)))))) + `(, @bind ,(map (lambda (binding) + (trc 'let binding) + (if (pair? binding) + `(,(car binding) ,(transformer (cadr binding))) + `(,binding ,%nil))) + (cadr exp)) + ,@(map transformer (cddr exp)))))) (fset 'let* (procedure->memoizing-macro @@ -234,11 +244,11 @@ (car (let loop ((bindings (cadr exp))) (if (null? bindings) (map transformer (cddr exp)) - `((@bind (,(let ((binding (car bindings))) - (if (pair? binding) - `(,(car binding) ,(transformer (cadr binding))) - `(,binding #f)))) - ,@(loop (cdr bindings))))))))))) + `((, @bind (,(let ((binding (car bindings))) + (if (pair? binding) + `(,(car binding) ,(transformer (cadr binding))) + `(,binding ,%nil)))) + ,@(loop (cdr bindings))))))))))) ;;; {Exception handling} diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index 0221dcc8a..f594c10cb 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -5,81 +5,98 @@ #:use-module (ice-9 session) #:export (transformer transform)) -;;; {S-expressions} +;;; A note on the difference between `(transform-* (cdr x))' and `(map +;;; transform-* (cdr x))'. ;;; +;;; In most cases, none, as most of the transform-* functions are +;;; recursive. +;;; +;;; However, if (cdr x) is not a proper list, the `map' version will +;;; signal an error immediately, whereas the non-`map' version will +;;; produce a similarly improper list as its transformed output. In +;;; some cases, improper lists are allowed, so at least these cases +;;; require non-`map'. +;;; +;;; Therefore we use the non-`map' approach in most cases below, but +;;; `map' in transform-application, since in the application case we +;;; know that `(func arg . args)' is an error. It would probably be +;;; better for the transform-application case to check for an improper +;;; list explicitly and signal a more explicit error. (define (syntax-error x) (error "Syntax error in expression" x)) -;; Should be made mutating instead of constructing -;; +(define-macro (scheme exp . module) + (let ((m (resolve-module (if (null? module) + '(guile-user) + (car module))))) + (let ((x `(,eval (,quote ,exp) ,m))) + (write x) + (newline) + x))) + (define (transformer x) + (cond ((pair? x) + (cond ((symbol? (car x)) + (case (car x) + ;; Allow module-related forms through intact. + ((define-module use-modules use-syntax) + x) + ;; Escape to Scheme. + ((scheme) + (cons-source x scheme (cdr x))) + ;; Quoting. + ((quote function) + (cons-source x quote (transform-quote (cdr x)))) + ((quasiquote) + (cons-source x quasiquote (transform-quasiquote (cdr x)))) + ;; Anything else is a function or macro application. + (else (transform-application x)))) + ((and (pair? (car x)) + (eq? (caar x) 'quasiquote)) + (transformer (car x))) + (else (syntax-error x)))) + (else + (transform-datum x)))) + +(define (transform-datum x) (cond ((eq? x 'nil) %nil) ((eq? x 't) #t) - ((null? x) %nil) - ((not (pair? x)) x) - ((and (pair? (car x)) - (eq? (caar x) 'quasiquote)) - (transformer (car x))) - ((symbol? (car x)) - (case (car x) - ((@fop @bind define-module use-modules use-syntax) x) - ; Escape to Scheme syntax - ((scheme) (cons begin (cdr x))) - ; Should be handled in reader - ((quote function) `(,quote ,@(cars->nil (cdr x)))) - ((quasiquote) (m-quasiquote x '())) - ;((nil-cond) (transform-1 x)) - ;((let) (m-let x '())) - ;((let*) (m-let* x '())) - ;((if) (m-if x '())) - ;((and) (m-and x '())) - ;((or) (m-or x '())) - ;((while) (m-while x '())) - ;((while) (cons macro-while (cdr x))) - ;((prog1) (m-prog1 x '())) - ;((prog2) (m-prog2 x '())) - ;((progn) (cons 'begin (map transformer (cdr x)))) - ;((cond) (m-cond x '())) - ;((lambda) (transform-lambda/interactive x ')) - ;((defun) (m-defun x '())) - ;((defmacro) (m-defmacro x '())) - ;((setq) (m-setq x '())) - ;((interactive) (fluid-set! interactive-spec x) #f) - ;((unwind-protect) (m-unwind-protect x '())) - (else (transform-application x)))) - (else (syntax-error x)))) + ;; Could add other translations here, notably `?A' -> 65 etc. + (else x))) -(define (m-quasiquote exp env) - (cons quasiquote - (map transform-inside-qq (cdr exp)))) +(define (transform-quote x) + (trc 'transform-quote x) + (cond ((not (pair? x)) + (transform-datum x)) + (else + (cons-source x + (transform-quote (car x)) + (transform-quote (cdr x)))))) -(define (transform-inside-qq x) - (trc 'transform-inside-qq x) - (cond ((not (pair? x)) x) +(define (transform-quasiquote x) + (trc 'transform-quasiquote x) + (cond ((not (pair? x)) + (transform-datum x)) ((symbol? (car x)) (case (car x) ((unquote) (list 'unquote (transformer (cadr x)))) ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x)))) - (else (cons (car x) (map transform-inside-qq (cdr x)))))) + (else (cons-source x + (transform-datum (car x)) + (transform-quasiquote (cdr x)))))) (else - (cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x)))))) + (cons-source x + (transform-quasiquote (car x)) + (transform-quasiquote (cdr x)))))) (define (transform-application x) - (cons-source x - '@fop - `(,(car x) (,transformer-macro ,@(cdr x))))) + (cons-source x @fop `(,(car x) (,transformer-macro ,@(map transform-quote (cdr x)))))) (define transformer-macro (procedure->memoizing-macro (let ((cdr cdr)) (lambda (exp env) - (cons 'list (map transformer (cdr exp))))))) - -(define (cars->nil ls) - (cond ((not (pair? ls)) ls) - ((null? (car ls)) (cons '() (cars->nil (cdr ls)))) - (else (cons (cars->nil (car ls)) - (cars->nil (cdr ls)))))) + (cons-source exp list (map transformer (cdr exp))))))) (define transform transformer) From a64e66698054f30642b37b83dcf12f45b1d86d3c Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 8 Feb 2002 13:00:30 +0000 Subject: [PATCH 10/81] * Add tests of Elisp expression evaluation. --- test-suite/ChangeLog | 4 ++ test-suite/tests/elisp.test | 73 +++++++++++++++++++++++++++++++++++++ 2 files changed, 77 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index c18b87194..cfb8602a7 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2002-02-08 Neil Jerram + + * tests/elisp.test: Add tests of Elisp expression evaluation. + 2002-01-25 Neil Jerram * tests/load.test: New test; for search-path with Elisp diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index a7a4c4a51..ab0039332 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -279,4 +279,77 @@ )) +(if (defined? '%nil) + (use-modules (lang elisp interface))) + +(if (defined? '%nil) + + (with-test-prefix "elisp" + + (define (elisp-pass-if expr expected) + (pass-if (with-output-to-string + (lambda () + (write expr))) + (let ((calc (with-output-to-string + (lambda () + (write (eval-elisp expr)))))) + (string=? calc expected)))) + + (elisp-pass-if '(and #f) "#f") + (elisp-pass-if '(and #t) "#t") + (elisp-pass-if '(and nil) "#nil") + (elisp-pass-if '(and t) "#t") + (elisp-pass-if '(and) "#t") + (elisp-pass-if '(cond (nil t) (t 3)) "3") + (elisp-pass-if '(cond (nil t) (t)) "#t") + (elisp-pass-if '(cond (nil)) "#nil") + (elisp-pass-if '(cond) "#nil") + (elisp-pass-if '(if #f 'a 'b) "b") + (elisp-pass-if '(if #t 'a 'b) "a") + (elisp-pass-if '(if '() 'a 'b) "b") + (elisp-pass-if '(if nil 'a 'b) "b") + (elisp-pass-if '(if nil 1 2 3 4) "4") + (elisp-pass-if '(if nil 1 2) "2") + (elisp-pass-if '(if nil 1) "#nil") + (elisp-pass-if '(if t 1 2) "1") + (elisp-pass-if '(if t 1) "1") + (elisp-pass-if '(let (a) a) "#nil") + (elisp-pass-if '(let* (a) a) "#nil") + (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2") + (elisp-pass-if '(memq '() '(())) "(())") + (elisp-pass-if '(memq '() '(nil)) "(#nil)") + (elisp-pass-if '(memq '() '(t)) "#nil") + (elisp-pass-if '(memq nil '(())) "(())") + (elisp-pass-if '(memq nil '(nil)) "(#nil)") + (elisp-pass-if '(memq nil (list nil)) "(#nil)") + (elisp-pass-if '(null '#f) "#t") + (elisp-pass-if '(null '()) "#t") + (elisp-pass-if '(null 'nil) "#t") + (elisp-pass-if '(null nil) "#t") + (elisp-pass-if '(or 1 2 3) "1") + (elisp-pass-if '(or nil t nil) "#t") + (elisp-pass-if '(or nil) "#nil") + (elisp-pass-if '(or t nil t) "#t") + (elisp-pass-if '(or t) "#t") + (elisp-pass-if '(or) "#nil") + (elisp-pass-if '(prog1 1 2 3) "1") + (elisp-pass-if '(prog2 1 2 3) "2") + (elisp-pass-if '(progn 1 2 3) "3") + (elisp-pass-if '(while nil 1) "#nil") + + (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r)) "testf") + (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)") + (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))") + ;; NB `lambda' in Emacs is self-quoting, but that's only after + ;; loading the macro definition of lambda in subr.el. + (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))") + (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))") + (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) "(1 2 3 #nil)") + + (elisp-pass-if '(setq x 3) "3") + (elisp-pass-if '(defvar x 4) "x") + (elisp-pass-if 'x "3") + + )) + ;;; elisp.test ends here From db755b31806cdb91a419b0cabb2282d85e2f72f6 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 8 Feb 2002 20:01:35 +0000 Subject: [PATCH 11/81] Initial revision --- devel/modules/signatures.scm | 0 devel/modules/signatures.texi | 0 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 devel/modules/signatures.scm create mode 100644 devel/modules/signatures.texi diff --git a/devel/modules/signatures.scm b/devel/modules/signatures.scm new file mode 100644 index 000000000..e69de29bb diff --git a/devel/modules/signatures.texi b/devel/modules/signatures.texi new file mode 100644 index 000000000..e69de29bb From 4f72f0a7f9f3749b4b3a3ee51fcd7a6792910acd Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 00:31:22 +0000 Subject: [PATCH 12/81] Initial revision --- devel/policy/exceptions.text | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 devel/policy/exceptions.text diff --git a/devel/policy/exceptions.text b/devel/policy/exceptions.text new file mode 100644 index 000000000..e69de29bb From c0fa6561ac9cd9c58b2329237c962d34e4403279 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 00:38:43 +0000 Subject: [PATCH 13/81] (create_gsubr): On "too many args" error, also display arg count and name. --- libguile/gsubr.c | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 767fc69ea..03d16809d 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,15 +1,15 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,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 software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -62,7 +62,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); SCM scm_f_gsubr_apply; static SCM -create_gsubr (int define, const char *name, +create_gsubr (int define, const char *name, int req, int opt, int rst, SCM (*fcn)()) { SCM subr; @@ -103,7 +103,9 @@ create_gsubr (int define, const char *name, SCM sym = SCM_SUBR_ENTRY(subr).name; if (SCM_GSUBR_MAX < req + opt + rst) { - fputs ("ERROR in scm_c_make_gsubr: too many args\n", stderr); + fprintf (stderr, + "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n", + req + opt + rst, name); exit (1); } SCM_SET_GSUBR_PROC (cclo, subr); @@ -215,8 +217,8 @@ scm_gsubr_apply (SCM args) long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ); #if 0 if (n > SCM_GSUBR_MAX) - scm_misc_error (FUNC_NAME, - "Function ~S has illegal arity ~S.", + scm_misc_error (FUNC_NAME, + "Function ~S has illegal arity ~S.", scm_list_2 (self, SCM_MAKINUM (n))); #endif args = SCM_CDR (args); @@ -258,7 +260,7 @@ scm_gsubr_apply (SCM args) #ifdef GSUBR_TEST /* A silly example, taking 2 required args, 1 optional, and - a scm_list of rest args + a scm_list of rest args */ SCM gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst) From 66adc0a6f2acf2c5713ed3b962234994bf408a73 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 00:39:59 +0000 Subject: [PATCH 14/81] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a0680ab60..2382b8f7b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2002-02-08 Thien-Thi Nguyen + + * gsubr.c (create_gsubr): On "too many args" error, + also display arg count and name. Thanks to Bill Schottstaedt. + 2002-02-05 Thien-Thi Nguyen * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. From cc4c7bd4dc9264f007cbd678a5b6c522efcc1820 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 05:43:48 +0000 Subject: [PATCH 15/81] (AUTOMAKE_OPTIONS): Replace "foreign" with "gnu". --- guile-readline/Makefile.am | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index d9d8d7d31..f1fefd605 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -3,23 +3,23 @@ ## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. -## +## ## GUILE is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as ## published by the Free Software Foundation; either version 2, or ## (at your option) any later version. -## +## ## GUILE is distributed in the hope that it will be useful, but ## WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. -## +## ## You should have received a copy of the GNU General Public ## License along with GUILE; see the file COPYING. If not, write ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -AUTOMAKE_OPTIONS = foreign +AUTOMAKE_OPTIONS = gnu ## Prevent automake from adding extra -I options DEFS = @DEFS@ @EXTRA_DEFS@ From 51477c02e0f88038aa1470cb350d03129aff0815 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 05:44:39 +0000 Subject: [PATCH 16/81] *** empty log message *** --- guile-readline/ChangeLog | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index e56498535..fc0f8889a 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,7 @@ +2002-02-08 Thien-Thi Nguyen + + * Makefile.am (AUTOMAKE_OPTIONS): Replace "foreign" with "gnu". + 2002-01-29 Neil Jerram * readline.scm (with-readline-completion-function): Renamed from @@ -24,7 +28,7 @@ 2001-11-02 Marius Vollmer Support for native Win32. Thanks to Stefan Jahn! - + * Makefile.am: Put `-export-dynamic -no-undefined' into LDFLAGS and add the library `libguile.la' to support linkers which do not allow unresolved symbols inside shared libraries. @@ -55,7 +59,7 @@ * readline.scm: Use load-extension instead of explicit dynamic-link/dynamic-call. Removed ".so" extension from library name. - + 2001-08-02 Neil Jerram * readline.scm (call-with-readline-completion-function): New. From 068a9d87f878002b7b02ebc63cd05c604173d471 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 22:26:20 +0000 Subject: [PATCH 17/81] (main): Handle `--flag-unresolved'. No longer set exit value to #f unconditionally on UNRESOLVED results. --- test-suite/guile-test | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/test-suite/guile-test b/test-suite/guile-test index a040c0da2..05703c593 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -6,17 +6,17 @@ ;;;; Jim Blandy --- May 1999 ;;;; ;;;; Copyright (C) 1999, 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 software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -36,16 +36,19 @@ ;;;; Scheme code.) However, you can have it execute specific tests by ;;;; listing their filenames on the command line. ;;;; -;;;; The option '--test-suite' can be given to specify the test +;;;; The option `--test-suite' can be given to specify the test ;;;; directory. If no such option is given, the test directory is ;;;; taken from the environment variable TEST_SUITE_DIR (if defined), -;;;; otherwise a default directory that is hardcoded in this file is +;;;; otherwise a default directory that is hardcoded in this file is ;;;; used (see "Installation" below). ;;;; ;;;; If present, the `--log-file LOG' option tells `guile-test' to put ;;;; the log output in a file named LOG. ;;;; -;;;; If present, the '--debug' option will enable a debugging mode. +;;;; If present, the `--debug' option will enable a debugging mode. +;;;; +;;;; If present, the `--flag-unresolved' option will cause guile-test +;;;; to exit with failure status if any tests are UNRESOLVED. ;;;; ;;;; ;;;; Installation: @@ -105,7 +108,7 @@ ;;; symlinks. (define (for-each-file f root) - ;; A "hard directory" is a path that denotes a directory and is not a + ;; A "hard directory" is a path that denotes a directory and is not a ;; symlink. (define (file-is-hard-directory? filename) (eq? (stat:type (lstat filename)) 'directory)) @@ -116,7 +119,7 @@ (let ((dir (opendir root))) (let loop () (let ((entry (readdir dir))) - (cond + (cond ((eof-object? entry) #f) ((or (string=? entry ".") (string=? entry "..")) @@ -157,13 +160,15 @@ (define (main args) (let ((options (getopt-long args - `((test-suite + `((test-suite (single-char #\t) (value #t)) - (log-file + (flag-unresolved + (single-char #\u)) + (log-file (single-char #\l) (value #t)) - (debug + (debug (single-char #\d)))))) (define (opt tag default) (let ((pair (assq tag options))) @@ -184,10 +189,10 @@ (let* ((tests (let ((foo (opt '() '()))) - (if (null? foo) + (if (null? foo) (enumerate-tests test-suite) foo))) - (log-file + (log-file (opt 'log-file "guile.log"))) ;; Open the log file. @@ -201,7 +206,10 @@ (register-reporter user-reporter) (register-reporter (lambda results (case (car results) - ((fail upass unresolved error) + ((unresolved) + (and (opt 'flag-unresolved #f) + (set! global-pass #f))) + ((fail upass error) (set! global-pass #f))))) ;; Run the tests. From ecfea4f9bd0043c1421ad389adbc74e07edad6fd Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 22:31:07 +0000 Subject: [PATCH 18/81] Initial revision --- devel/build/testing.text | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 devel/build/testing.text diff --git a/devel/build/testing.text b/devel/build/testing.text new file mode 100644 index 000000000..1ea371380 --- /dev/null +++ b/devel/build/testing.text @@ -0,0 +1,9 @@ +Some Notes on Testing +--------------------- + +To not alarm users, "make check" (which runs "check-guile" which +runs "test-suite/guile-test") does not fail on UNRESOLVED tests. + +Maintainers who want to be more strict should use: + + ./check-guile --flag-unresolved From ecb471f939a606b04f5fe8dfc4de209711d630bb Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 22:35:39 +0000 Subject: [PATCH 19/81] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index cfb8602a7..5733e81c8 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2002-02-09 Thien-Thi Nguyen + + * guile-test (main): Handle `--flag-unresolved'. No longer set + exit value to #f unconditionally on UNRESOLVED results. + 2002-02-08 Neil Jerram * tests/elisp.test: Add tests of Elisp expression evaluation. From 1febd88c0f466075c35492ac6f8e4b8a195da3d8 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 22:42:54 +0000 Subject: [PATCH 20/81] (for-each-file): Do not recurse into "CVS" or "RCS" subdirs. --- test-suite/guile-test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test-suite/guile-test b/test-suite/guile-test index 05703c593..1d16368d8 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -122,7 +122,9 @@ (cond ((eof-object? entry) #f) ((or (string=? entry ".") - (string=? entry "..")) + (string=? entry "..") + (string=? entry "CVS") + (string=? entry "RCS")) (loop)) (else (visit (string-append root "/" entry)) From e383ab49300a7a7924445a40be893e7e430a1781 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 22:43:50 +0000 Subject: [PATCH 21/81] *** empty log message *** --- test-suite/ChangeLog | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5733e81c8..68cc4bef1 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -2,6 +2,7 @@ * guile-test (main): Handle `--flag-unresolved'. No longer set exit value to #f unconditionally on UNRESOLVED results. + (for-each-file): Do not recurse into "CVS" or "RCS" subdirs. 2002-02-08 Neil Jerram From 05aabdf060de3dde263e6e6ae47793a98bd70341 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 23:22:32 +0000 Subject: [PATCH 22/81] Remove cruft; nfc. --- libguile/Makefile.am | 8 -------- 1 file changed, 8 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e0d1dfbd4..e914eee86 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -98,14 +98,6 @@ EXTRA_libguile_la_SOURCES = _scm.h \ ramap.c unif.c debug-malloc.c mkstemp.c \ win32-uname.c win32-dirent.c win32-socket.c -## In next release, threads will be factored out of libguile. -## Until then, the machine specific headers is a temporary kludge. - -# Seems to be obsolete - autogen.sh is giving: -# invalid unused variable name: `OMIT_DEPENDENCIES' -#OMIT_DEPENDENCIES = libguile.h ltdl.h \ -# axp.h hppa.h i386.h ksr.h m88k.h mips.h sparc.h vax.h - ## delete guile-snarf.awk from the installation bindir, in case it's ## lingering there due to an earlier guile version not having been ## wiped out. From 08df2d52504dbef727a1dbb6d1e6d0ea9fa2fd25 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 10 Feb 2002 19:15:20 +0000 Subject: [PATCH 23/81] Mention "check-guile --debug". --- devel/build/testing.text | 9 --------- 1 file changed, 9 deletions(-) diff --git a/devel/build/testing.text b/devel/build/testing.text index 1ea371380..e69de29bb 100644 --- a/devel/build/testing.text +++ b/devel/build/testing.text @@ -1,9 +0,0 @@ -Some Notes on Testing ---------------------- - -To not alarm users, "make check" (which runs "check-guile" which -runs "test-suite/guile-test") does not fail on UNRESOLVED tests. - -Maintainers who want to be more strict should use: - - ./check-guile --flag-unresolved From 9e05aed387e633f4cf4305dc9da241ee74f6341f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Feb 2002 16:27:55 +0000 Subject: [PATCH 24/81] (GUILE_DEBUG_MALLOC): Refer to scm_gc_malloc, etc, instead of to scm_must_malloc. --- acconfig.h | 174 ----------------------------------------------------- 1 file changed, 174 deletions(-) diff --git a/acconfig.h b/acconfig.h index 578d76399..e69de29bb 100644 --- a/acconfig.h +++ b/acconfig.h @@ -1,174 +0,0 @@ -/* acconfig.h --- documentation for symbols possibly defined in scmconfig.h - * The `autoheader' command, from the autoconf suite, generates - * libguile/scmconfig.h, based on configure.in and this file. - * - * Copyright (C) 1998, 2000 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 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. */ - - -/* Define this to 1 if you want to include deprecated features */ -#undef SCM_ENABLE_DEPRECATED - -/* Define this to control the default warning level for deprecated features */ -#undef SCM_WARN_DEPRECATED_DEFAULT - -/* Define these two if you want support for debugging of Scheme - programs. */ -#undef DEBUG_EXTENSIONS -#undef READER_EXTENSIONS - -/* Define this if you want to debug the free list (helps w/ GC bugs) */ -#undef GUILE_DEBUG_FREELIST - -/* Define this if you want to debug scm_must_malloc/realloc/free calls */ -#undef GUILE_DEBUG_MALLOC - -/* Define this if your system defines S_ISLNK in sys/stat.h */ -#undef HAVE_S_ISLNK - -/* Define this if your system defines struct linger, for use with the - getsockopt and setsockopt system calls. */ -#undef HAVE_STRUCT_LINGER - -/* Define this if your system defines struct timespec via . */ -#undef HAVE_STRUCT_TIMESPEC - -/* Define this if floats are the same size as longs. */ -#undef SCM_SINGLES - -/* Define this if a callee's stack frame has a higher address than the - caller's stack frame. On most machines, this is not the case. */ -#undef SCM_STACK_GROWS_UP - -/* Define this if doesn't define struct utimbuf unless - _POSIX_SOURCE is #defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4. */ -#undef UTIMBUF_NEEDS_POSIX - -/* Define this if we should #include when we've already - #included . On some systems, they conflict, and libc.h - should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in - aclocal.m4. */ -#undef LIBC_H_WITH_UNISTD_H - -/* Define this to include various undocumented functions used to debug - the Guile library itself. */ -#undef GUILE_DEBUG - -/* Define to implement scm_internal_select */ -#undef GUILE_ISELECT - -/* Define to enable workaround for COOP-linuxthreads compatibility */ -#undef GUILE_PTHREAD_COMPAT - -/* Define if using cooperative multithreading. */ -#undef USE_COOP_THREADS - -/* Define if using any sort of threads. */ -#undef USE_THREADS - -/* Define if you want support for dynamic linking. */ -#undef DYNAMIC_LINKING - -/* Define if symbol tables on this system use leading underscores. */ -#undef USCORE - -/* Define if dlsym automatically supplies a leading underscore. */ -#undef DLSYM_ADDS_USCORE - -/* Define if h_errno is declared in netdb.h. */ -#undef HAVE_H_ERRNO - -/* Define if uint32_t typedef is defined when netdb.h is include. */ -#undef HAVE_UINT32_T - -/* Define if you want support for IPv6. */ -#undef HAVE_IPV6 - -/* Define if localtime caches the TZ setting. */ -#undef LOCALTIME_CACHE - -/* Define if the operating system can restart system calls. */ -#undef HAVE_RESTARTS - -/* Define if the system supports Unix-domain (file-domain) sockets. */ -#undef HAVE_UNIX_DOMAIN_SOCKETS - -/* Define this if you want support for arrays and uniform arrays. */ -#undef HAVE_ARRAYS - -/* Define this if you want Elisp support (in addition to Scheme). */ -#undef SCM_ENABLE_ELISP - -/* Define this if your IPv6 has sin6_scope_id in sockaddr_in6 struct. */ -#undef HAVE_SIN6_SCOPE_ID - -/* This is included as part of a workaround for a autoheader bug. */ -#undef HAVE_REGCOMP - -/* Define this if you want support for POSIX system calls in Guile. */ -#undef HAVE_POSIX - -/* Define this if you want support for networking in Guile. */ -#undef HAVE_NETWORKING - -/* Define if the operating system supplies bzero without declaring it. */ -#undef MISSING_BZERO_DECL - -/* Define if the operating system supplies strptime without declaring it. */ -#undef MISSING_STRPTIME_DECL - -/* Define if the operating system supplies sleep without declaring it. */ -#undef MISSING_SLEEP_DECL - -/* Define if the operating system supplies usleep without declaring it. */ -#undef MISSING_USLEEP_DECL - -/* Define if the system headers declare usleep to return void. */ -#undef USLEEP_RETURNS_VOID - -/* Define if your readline library has the rl_getc_function variable. */ -#undef HAVE_RL_GETC_FUNCTION - -/* Define if the compiler supports long longs. */ -#undef HAVE_LONG_LONGS - -/* Define if the compiler supports inline functions. */ -#undef HAVE_INLINE From 0906625fbcfc5cc443fa4271a871ed3bd9e0bc83 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Feb 2002 16:28:17 +0000 Subject: [PATCH 25/81] Entry about scm_gc_malloc and friends. --- NEWS | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/NEWS b/NEWS index 05904d621..dd3e4c1db 100644 --- a/NEWS +++ b/NEWS @@ -52,6 +52,26 @@ Use `substring-move!' instead. * Changes to the C interface +** New functions for memory management + +A new set of functions for memory management has been added since the +old way (scm_must_malloc, scm_must_free, etc) was error prone and +indeed, Guile itself contained some long standing bugs that could +cause aborts in long running programs. + +The new functions are more symmetrical and do not need cooperation +from smob free routines, among other improvements. + +The new functions are scm_malloc, scm_realloc, scm_strdup, +scm_strndup, scm_gc_malloc, scm_gc_realloc, scm_gc_free, +scm_gc_register_collectable_memory, and +scm_gc_unregister_collectable_memory. Refer to the manual for more +details and for upgrading instructions. + +The old functions for memory management have been deprecated. They +are: scm_must_malloc, scm_must_realloc, scm_must_free, +scm_must_strdup, scm_must_strndup, scm_done_malloc, scm_done_free. + ** New function: scm_str2string This function creates a scheme string from a 0-terminated C string. The input From 84b271655583bb3b79840b818d280f502fad76e6 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Feb 2002 16:28:28 +0000 Subject: [PATCH 26/81] *** empty log message *** --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 43498cb31..e43ce5fa4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2002-02-11 Marius Vollmer + + * acconfig.h (GUILE_DEBUG_MALLOC): Refer to scm_gc_malloc, etc, + instead of to scm_must_malloc. + 2002-02-07 Marius Vollmer * Makefile.am (EXTRA_DIST): Added pre-inst-guile and From 9d8c42820cb610858e41694ada945dc9bbcd7d4b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Feb 2002 16:29:20 +0000 Subject: [PATCH 27/81] Small fixes. --- devel/memory.text | 207 ---------------------------------------------- 1 file changed, 207 deletions(-) diff --git a/devel/memory.text b/devel/memory.text index 0e7912e10..e69de29bb 100644 --- a/devel/memory.text +++ b/devel/memory.text @@ -1,207 +0,0 @@ -The following is gathered from a shortish discussion on the -guile-devel mailing list. I plan to implement this in the next -days. -mvo - -Improving memory handling in Guile ----------------------------------- - -I think we have a problem with the `mallocated' GC trigger. It is not -maintained reliably and I'm afraid we need to have everybody review -their code to get it right. - -I think the current interface with scm_must_malloc, scm_must_free, -scm_done_malloc, scm_done_free is too difficult to use right and too -hard to debug. - -Guile itself is full of mtrigger related bugs, I'm afraid. A typical -one is in fports.c: the buffers for a fport are allocated with -scm_must_malloc and freed with scm_must_free. The allocation is -reported to the GC, but the freeing never is. The result is that the -GC thinks that more and more memory is being allocated that it should -be able to free, but that never actually gets freed (although in -reality the program is very well behaved). As a counter measure to -constant GC, the GC raises its mtrigger setting in a frenzy until it -wraps around, causing a `hallucinating GC' syndrome, effectively -stopping the program dead. - -(Watch scm_mtrigger while your favorite long-running Guile program -executes, it will continuously rise.) - -The problem is that scm_must_malloc registers the allocated amount -with the GC, but scm_must_free does not de-register it. For that, one -would currently needs to use scm_done_free, or return an appropriate -number from a smob free routine. - -Another problem is that scm_must_malloc is used in places where it is -probably not appropriate since the caller does not know whether that -block memory is really ending up under the control of the GC, or not. -For example scm_do_read_line in rdelim.c uses scm_must_malloc to -allocate a buffer that it returns, and scm_read_line passes this to -scm_take_string. scm_take_string assumes that the memory has not been -under GC control previously and calls scm_done_malloc to account for -the fact that it now is. But scm_must_malloc has _already_ increased -scm_mallocated by the proper amount. Thus, it is now doubly -reflected. - -Since the current interface is unsymmetrical (scm_must_malloc -registers, but scm_must_free doesn't de-register), I propose to change -it as follows. Switching to this new interface will force us and -everybody else to systematically review their code. - - - the smob free routine does no longer return the number of bytes - that have been freed. For the transition period, free routines - are first encourged to return 0, then required, and then their - return type changes to void. - - - scm_must_malloc, scm_must_free are deprecated. - - - in their place, we have - - Function: void *scm_malloc (size_t size); - - Allocate SIZE bytes of memory. When not enough memory is - available, signal an error. This function runs the GC to free - up some memory when it deems it appropriate. - - The memory is allocated by the libc "malloc" function and can - be freed with "free". We do not introduce a `scm_free' - function to go with scm_malloc to make it easier to pass - memory back and forth between different modules. - - [ Note: this function will not consider the memory block to be - under GC control. ] - - Function: void *scm_realloc (void *mem, size_t newsize); - - Change the size of the memory block at MEM to NEWSIZE. A new - pointer is returned. When NEWSIZE is 0 this is the same as - calling scm_free on MEM and NULL is returned. When MEM is - NULL, this function behaves like scm_malloc and allocates a - new block of size SIZE. - - When not enough memory is available, signal an error. This - function runs the GC to free up some memory when it deems it - appropriate. - - Function: void scm_gc_register_collectable_memory - (void *mem, size_t size, const char *what); - - Informs the GC that the memory at MEM of size SIZE can - potentially be freed during a GC. That is, announce that MEM - is part of a GC controlled object and when the GC happens to - free that object, SIZE bytes will be freed along with it. The - GC will _not_ free the memory itself, it will just know that - so-and-so much bytes of memory are associated with GC - controlled objects and the memory system figures this into its - decisions when to run a GC. - - MEM does not need to come from scm_malloc. You can only call - this function once for every memory block. - - The WHAT argument is used for statistical purposes. It should - describe the type of object that the memory will be used for - so that users can identify just what strange objects are - eating up their memory. - - Function: void scm_gc_unregister_collectable_memory - (void *mem, size_t size); - - Inform the GC that the memory at MEM of size SIZE is no longer - associated with a GC controlled object. You must take care to - match up every call to scm_gc_register_collectable_memory with - a call to scm_gc_unregister_collectable_memory. If you don't - do this, the GC might have a wrong impression of what is going - on and run much less efficiently than it could. - - Function: void *scm_gc_malloc (size_t size, const char *what); - Function: void *scm_gc_realloc (void *mem, size_t size, - const char *what); - - Like scm_malloc, but also call scm_gc_register_collectable_memory. - - Function: void scm_gc_free (void *mem, size_t size, const char *what); - - Like free, but also call scm_gc_unregister_collectable_memory. - - Note that you need to explicitely pass the SIZE parameter. - This is done since it should normally be easy to provide this - parameter (for memory that is associated with GC controlled - objects) and this frees us from tracking this value in the GC - itself. (We don't do this out of lazyness but because it will - keep the memory management overhead very low.) - -The normal thing to use is scm_gc_malloc, scm_gc_realloc, and scm_gc_free. - - -Cell allocation and initialization ----------------------------------- - -The following has been implemented in the unstable branch now. - -It can happen that the GC is invoked during the code that initializes -a cell. The half initialized cell is seen by the GC, which would -normally cause it to crash. To prevent this, the initialization code -is careful to set the type tag of the cell last, so that the GC will -either see a completely initialized cell, or a cell with type tag -`free_cell'. However, some slot of that `free' cell might be the only -place where a live object is referenced from (since the compiler might -reuse the stack location or register that held it before it was -stuffed into the cell). To protect such an object, the contents of -the cell (except the first word) is marked conservatively. - -What happened to me was that scm_gc_mark hit upon a completely -uninitialized cell, that was tagged a s a free cell, and still pointed -to the rest of the freelist were it came from. (It was probably this code - - : - SCM_NEWCELL (port); // port is a free cell - SCM_DEFER_INTS; - pt = scm_add_to_port_table (port); // this invokes the GC - : - -that caused it.) - -scm_gc_mark would conservatively mark the cdr of the free cell, which -resulted in marking the whole free list. This caused a stack overflow -because the marking didn't happen in a tail-calling manner. (Even if -it doesn't crash, a lot of unnecessary work is done.) - -I propose to change the current practice so that no half initialized -cell is ever seen by the GC. scm_gc_mark would abort on seeing a free -cell, and scm_mark_locations (and scm_gc_mark_cell_conservatively if -will survive) would not mark a free cell, even if the pointer points -to a valid cell. scm_gc_sweep would continue to ignore free cells. - -To ensure that initialization can not be interrupted by a GC, we -provide new functions/macros to allocate a cell that include -initialization. For example - - SCM scm_newcell_init (scm_bits_t car, scm_bits_t cdr) - { - SCM z; - if (SCM_NULLP (scm_freelist)) - z = scm_gc_for_newcell (&scm_master_freelist, - &scm_freelist); - else - { - z = scm_freelist; - scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); - } - SCM_SET_CELL_WORD_1 (z, cdr); - SCM_SET_CELL_WORD_0 (z, car); - scm_remember_upto_here (cdr); - return into; - } - -For performance, we might turn this into a macro, and find some -specialized ways to make the compiler remember certain values (like -some `asm' statement for GCC). For a non-threaded Guile, and a -cooperatively threaded one, the scm_remember_upto_here call is not -even needed since we know the the function can not be -interrupted. (Signals can not interrupt the flow of control any -longer). - -In the transition period, while SCM_NEWCELL is deprecated, we can make -it always initialize the first slot with scm_tc16_allocated. Such -cells are marked conservatively by the GC. SCM_NEWCELL can have -abysmal performance while being deprecated. From d013f095c14783c193385cb67d3778a1240cd19b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Feb 2002 17:17:48 +0000 Subject: [PATCH 28/81] Reimplemented to allow deprecation messages while the GC is running. (scm_c_issue_deprecation_warning_fmt): New. --- libguile/deprecation.c | 83 ++++++++++++++++++++++++++++++------------ libguile/deprecation.h | 1 + 2 files changed, 60 insertions(+), 24 deletions(-) diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 192f25519..17f3641dc 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -43,11 +43,11 @@ #include #include +#include #include "libguile/_scm.h" #include "libguile/deprecation.h" -#include "libguile/hashtab.h" #include "libguile/strings.h" #include "libguile/ports.h" @@ -55,18 +55,52 @@ #if (SCM_ENABLE_DEPRECATED == 1) -/* This is either a boolean (when a summary should be printed) or a - hashtab (when detailed warnings should be printed). -*/ -SCM issued_msgs; +struct issued_warning { + struct issued_warning *prev; + const char *message; +}; + +static struct issued_warning *issued_warnings; +static enum { detailed, summary, summary_print } mode; void scm_c_issue_deprecation_warning (const char *msg) { - if (SCM_BOOLP (issued_msgs)) - issued_msgs = SCM_BOOL_T; + if (mode != detailed) + mode = summary_print; else - scm_issue_deprecation_warning (scm_list_1 (scm_makfrom0str (msg))); + { + struct issued_warning *iw; + for (iw = issued_warnings; iw; iw = iw->prev) + if (!strcmp (iw->message, msg)) + return; + if (scm_gc_running_p) + fprintf (stderr, "%s\n", msg); + else + { + scm_puts (msg, scm_current_error_port ()); + scm_newline (scm_current_error_port ()); + } + msg = strdup (msg); + iw = malloc (sizeof (struct issued_warning)); + if (msg == NULL || iw == NULL) + return; + iw->message = msg; + iw->prev = issued_warnings; + issued_warnings = iw; + } +} + +void +scm_c_issue_deprecation_warning_fmt (const char *msg, ...) +{ + va_list ap; + char buf[512]; + + va_start (ap, msg); + vsnprintf (buf, 511, msg, ap); + buf[511] = '\0'; + scm_c_issue_deprecation_warning (buf); } SCM_DEFINE(scm_issue_deprecation_warning, @@ -74,26 +108,27 @@ SCM_DEFINE(scm_issue_deprecation_warning, (SCM msgs), "Output @var{msgs} to @code{(current-error-port)} when this " "is the first call to @code{issue-deprecation-warning} with " - "this specific @var{msg}. Do nothing otherwise. " + "this specific @var{msgs}. Do nothing otherwise. " "The argument @var{msgs} should be a list of strings; " "they are printed in turn, each one followed by a newline.") #define FUNC_NAME s_scm_issue_deprecation_warning { - if (SCM_BOOLP (issued_msgs)) - issued_msgs = SCM_BOOL_T; + if (mode != detailed) + mode = summary_print; else { - SCM handle = scm_hash_create_handle_x (issued_msgs, msgs, SCM_BOOL_F); - if (SCM_CDR (handle) == SCM_BOOL_F) + SCM nl = scm_str2string ("\n"); + SCM msgs_nl = SCM_EOL; + while (SCM_CONSP (msgs)) { - while (SCM_CONSP (msgs)) - { - scm_display (SCM_CAR (msgs), scm_current_error_port ()); - scm_newline (scm_current_error_port ()); - msgs = SCM_CDR (msgs); - } - SCM_SETCDR (handle, SCM_BOOL_T); + if (msgs_nl != SCM_EOL) + msgs_nl = scm_cons (nl, msgs_nl); + msgs_nl = scm_cons (SCM_CAR (msgs), msgs_nl); + msgs = SCM_CDR (msgs); } + msgs_nl = scm_string_append (scm_reverse_x (msgs_nl, SCM_EOL)); + scm_c_issue_deprecation_warning (SCM_STRING_CHARS (msgs_nl)); + scm_remember_upto_here_1 (msgs_nl); } return SCM_UNSPECIFIED; } @@ -102,7 +137,7 @@ SCM_DEFINE(scm_issue_deprecation_warning, static void print_deprecation_summary (void) { - if (issued_msgs == SCM_BOOL_T) + if (mode == summary_print) { fputs ("\n" "Some deprecated features have been used. Set the environment\n" @@ -136,12 +171,12 @@ scm_init_deprecation () if (level == NULL) level = SCM_WARN_DEPRECATED_DEFAULT; if (!strcmp (level, "detailed")) - issued_msgs = scm_permanent_object (scm_c_make_hash_table (17)); + mode = detailed; else if (!strcmp (level, "no")) - issued_msgs = SCM_BOOL_F; + mode = summary; else { - issued_msgs = SCM_BOOL_F; + mode = summary; atexit (print_deprecation_summary); } #endif diff --git a/libguile/deprecation.h b/libguile/deprecation.h index 22f666da3..c5967fed0 100644 --- a/libguile/deprecation.h +++ b/libguile/deprecation.h @@ -53,6 +53,7 @@ #if (SCM_ENABLE_DEPRECATED == 1) SCM_API void scm_c_issue_deprecation_warning (const char *msg); +SCM_API void scm_c_issue_deprecation_warning_fmt (const char *msg, ...); SCM_API SCM scm_issue_deprecation_warning (SCM msgs); #endif From 4c9419ac31f8364db51ccf25f7f9d5d31dd412e7 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Feb 2002 18:06:50 +0000 Subject: [PATCH 29/81] * gc.h, gc.c (scm_gc_sweep): Issue deprecation warning when non-zero is returned from a port or smob free function. (scm_malloc, scm_realloc, scm_strndup, scm_strdup, scm_gc_register_collectable_memory, scm_gc_unregister_collectable_memory, scm_gc_malloc, scm_gc_realloc, scm_gc_free, scm_gc_strndup, scm_gc_strdup): New. * backtrace.c, continuations.c, convert.i.c, coop-threads.c, debug-malloc.c, dynl.c, environments.c, environments.h, extensions.c, filesys.c, fports.c, gc.c, gc.h, gh_data.c, goops.c, guardians.c, hooks.c, init.c, keywords.c, load.c, numbers.c, ports.c, posix.c, procs.c, rdelim.c, regex-posix.c, root.c, smob.c, stime.c, strings.c, struct.c, struct.h, symbols.c, unif.c, vectors.c, weaks.c: Use scm_gc_malloc/scm_malloc and scm_gc_free/free instead of scm_must_malloc and scm_must_free, as appropriate. Return zero from smob and port free functions. * debug-malloc.c (scm_malloc_reregister): Handle "old == NULL". * fports.c (scm_setvbuf): Reset read buffer to saved values when it is pointing to the putback buffer. --- libguile/backtrace.c | 5 +- libguile/continuations.c | 17 ++-- libguile/convert.i.c | 6 +- libguile/coop-threads.c | 16 +-- libguile/debug-malloc.c | 47 +++++---- libguile/dynl.c | 11 +- libguile/environments.c | 39 ++++---- libguile/environments.h | 2 +- libguile/extensions.c | 7 +- libguile/filesys.c | 16 +-- libguile/fports.c | 26 +++-- libguile/gc.c | 211 +++++++++++++++++++++++++++++++++++---- libguile/gc.h | 16 +++ libguile/gh_data.c | 12 +-- libguile/goops.c | 21 ++-- libguile/guardians.c | 6 +- libguile/hooks.c | 5 +- libguile/init.c | 2 +- libguile/keywords.c | 5 +- libguile/load.c | 5 +- libguile/numbers.c | 11 +- libguile/ports.c | 32 +++--- libguile/posix.c | 18 ++-- libguile/procs.c | 12 +-- libguile/rdelim.c | 14 ++- libguile/regex-posix.c | 10 +- libguile/root.c | 8 +- libguile/smob.c | 9 +- libguile/stime.c | 26 ++--- libguile/strings.c | 4 +- libguile/struct.c | 29 +++--- libguile/struct.h | 13 +-- libguile/symbols.c | 10 +- libguile/unif.c | 18 ++-- libguile/vectors.c | 2 +- libguile/weaks.c | 2 +- 36 files changed, 439 insertions(+), 254 deletions(-) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index baa0e6e1a..feed5a12f 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -312,10 +312,9 @@ SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0, params, SCM_ARG2, s_scm_set_print_params_x); - new_params = scm_must_malloc (n * sizeof (print_params_t), - FUNC_NAME); + new_params = scm_malloc (n * sizeof (print_params_t)); if (print_params != default_print_params) - scm_must_free (print_params); + free (print_params); print_params = new_params; for (i = 0; i < n; ++i) { diff --git a/libguile/continuations.c b/libguile/continuations.c index cd89110fa..efc96de28 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -94,11 +94,11 @@ continuation_free (SCM obj) + extra_items * sizeof (SCM_STACKITEM); #ifdef __ia64__ - bytes_free += continuation->backing_store_size; - scm_must_free (continuation->backing_store); + scm_gc_free (continuation->backing_store, continuation->backing_store_size, + "continuation backing store"); #endif /* __ia64__ */ - scm_must_free (continuation); - return bytes_free; + scm_gc_free (continuation, bytes_free, "continuation"); + return 0; } static int @@ -146,9 +146,9 @@ scm_make_continuation (int *first) SCM_ENTER_A_SECTION; SCM_FLUSH_REGISTER_WINDOWS; stack_size = scm_stack_size (rootcont->base); - continuation = scm_must_malloc (sizeof (scm_t_contregs) - + (stack_size - 1) * sizeof (SCM_STACKITEM), - FUNC_NAME); + continuation = scm_gc_malloc (sizeof (scm_t_contregs) + + (stack_size - 1) * sizeof (SCM_STACKITEM), + "continuation"); continuation->num_stack_items = stack_size; continuation->dynenv = scm_dynwinds; continuation->throw_value = SCM_EOL; @@ -174,7 +174,8 @@ scm_make_continuation (int *first) (unsigned long) __libc_ia64_register_backing_store_base; continuation->backing_store = NULL; continuation->backing_store = - scm_must_malloc (continuation->backing_store_size, FUNC_NAME); + scm_gc_malloc (continuation->backing_store_size, + "continuation backing store"); memcpy (continuation->backing_store, (void *) __libc_ia64_register_backing_store_base, continuation->backing_store_size); diff --git a/libguile/convert.i.c b/libguile/convert.i.c index 118182943..7ab0eae25 100644 --- a/libguile/convert.i.c +++ b/libguile/convert.i.c @@ -152,8 +152,7 @@ CTYPES2UVECT (const CTYPE *data, long n) SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); - if ((v = (char *) SCM_MUST_MALLOC_TYPE_NUM (CTYPE, n)) == NULL) - return SCM_UNDEFINED; + v = scm_gc_malloc (sizeof (CTYPE) * n, "vector"); memcpy (v, data, n * sizeof (CTYPE)); return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); } @@ -168,8 +167,7 @@ CTYPES2UVECT2 (const unsigned CTYPE *data, long n) SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); - if ((v = (char *) SCM_MUST_MALLOC_TYPE_NUM (unsigned CTYPE, n)) == NULL) - return SCM_UNDEFINED; + v = scm_gc_malloc (sizeof (unsigned CTYPE) * n, "vector"); memcpy (v, data, n * sizeof (unsigned CTYPE)); return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v); } diff --git a/libguile/coop-threads.c b/libguile/coop-threads.c index 659264fc7..95498b310 100644 --- a/libguile/coop-threads.c +++ b/libguile/coop-threads.c @@ -324,7 +324,7 @@ c_launch_thread (void *p) data, (SCM_STACKITEM *) &thread); scm_thread_count--; - scm_must_free ((char *) data); + free ((char *) data); } SCM @@ -334,8 +334,7 @@ scm_spawn_thread (scm_t_catch_body body, void *body_data, SCM thread; coop_t *t; SCM root, old_winds; - c_launch_data *data = (c_launch_data *) scm_must_malloc (sizeof (*data), - "scm_spawn_thread"); + c_launch_data *data = (c_launch_data *) scm_malloc (sizeof (*data)); /* Unwind wind chain. */ old_winds = scm_dynwinds; @@ -414,11 +413,8 @@ scm_single_thread_p (void) SCM scm_make_mutex (void) { - SCM m; - coop_m *data = (coop_m *) scm_must_malloc (sizeof (coop_m), "mutex"); - - SCM_NEWSMOB (m, scm_tc16_mutex, (scm_t_bits) data); - coop_mutex_init (data); + SCM m = scm_make_smob (scm_tc16_mutex); + coop_mutex_init (SCM_MUTEX_DATA (m)); return m; } @@ -446,9 +442,7 @@ scm_unlock_mutex (SCM m) SCM scm_make_condition_variable (void) { - SCM c; - coop_c *data = (coop_c *) scm_must_malloc (sizeof (coop_c), "condvar"); - SCM_NEWSMOB (c, scm_tc16_condvar, (scm_t_bits) data); + SCM c = scm_make_smob (scm_tc16_condvar); coop_condition_variable_init (SCM_CONDVAR_DATA (c)); return c; } diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c index b3c5133d0..e85423dd1 100644 --- a/libguile/debug-malloc.c +++ b/libguile/debug-malloc.c @@ -183,7 +183,7 @@ scm_malloc_unregister (void *obj) if (type == 0) { fprintf (stderr, - "scm_must_free called on object not allocated with scm_must_malloc\n"); + "scm_gc_free called on object not allocated with scm_gc_malloc\n"); abort (); } type->data = (void *) ((int) type->data - 1); @@ -194,29 +194,36 @@ void scm_malloc_reregister (void *old, void *new, const char *newwhat) { hash_entry_t *object, *type; - GET_CREATE_HASH_ENTRY (object, object, old, l1); - type = (hash_entry_t *) object->data; - if (type == 0) + + if (old == NULL) + scm_malloc_register (new, newwhat); + else { - fprintf (stderr, - "scm_must_realloc called on object not allocated with scm_must_malloc\n"); - abort (); - } - if (strcmp ((char *) type->key, newwhat) != 0) - { - if (strcmp (newwhat, "vector-set-length!") != 0) + GET_CREATE_HASH_ENTRY (object, object, old, l1); + type = (hash_entry_t *) object->data; + if (type == 0) { fprintf (stderr, - "scm_must_realloc called with arg %s, was %s\n", - newwhat, - (char *) type->key); + "scm_gc_realloc called on object not allocated " + "with scm_gc_malloc\n"); abort (); } - } - if (new != old) - { - object->key = 0; - CREATE_HASH_ENTRY (object, new, type, l2); + if (strcmp ((char *) type->key, newwhat) != 0) + { + if (strcmp (newwhat, "vector-set-length!") != 0) + { + fprintf (stderr, + "scm_gc_realloc called with arg %s, was %s\n", + newwhat, + (char *) type->key); + abort (); + } + } + if (new != old) + { + object->key = 0; + CREATE_HASH_ENTRY (object, new, type, l2); + } } } @@ -224,7 +231,7 @@ SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0, (), "Return an alist ((@var{what} . @var{n}) ...) describing number\n" "of malloced objects.\n" - "@var{what} is the second argument to @code{scm_must_malloc},\n" + "@var{what} is the second argument to @code{scm_gc_malloc},\n" "@var{n} is the number of objects of that type currently\n" "allocated.") #define FUNC_NAME s_scm_malloc_stats diff --git a/libguile/dynl.c b/libguile/dynl.c index d920b2d7a..c3861cf71 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -89,7 +89,8 @@ maybe_drag_in_eprintf () (Dirk: IMO strings.c is not the right place.) */ static char ** -scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) +scm_make_argv_from_stringlist (SCM args, int *argcp, const char *subr, + int argn) { char **argv; int argc; @@ -97,7 +98,7 @@ scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) argc = scm_ilength (args); SCM_ASSERT (argc >= 0, args, argn, subr); - argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr); + argv = (char **) scm_malloc ((argc + 1) * sizeof (char *)); for (i = 0; !SCM_NULL_OR_NIL_P (args); args = SCM_CDR (args), ++i) { SCM arg = SCM_CAR (args); size_t len; @@ -107,7 +108,7 @@ scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr); len = SCM_STRING_LENGTH (arg); src = SCM_STRING_CHARS (arg); - dst = (char *) scm_must_malloc (len + 1, subr); + dst = (char *) scm_malloc (len + 1); memcpy (dst, src, len); dst[len] = 0; argv[i] = dst; @@ -120,7 +121,7 @@ scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) } static void -scm_must_free_argv(char **argv) +scm_free_argv (char **argv) { char **av = argv; while (*av) @@ -398,7 +399,7 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0, SCM_DEFER_INTS; argv = scm_make_argv_from_stringlist (args, &argc, FUNC_NAME, SCM_ARG3); result = (*fptr) (argc, argv); - scm_must_free_argv (argv); + scm_free_argv (argv); SCM_ALLOW_INTS; return SCM_MAKINUM (0L + result); diff --git a/libguile/environments.c b/libguile/environments.c index 237c8b28e..3db13b036 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -476,7 +476,8 @@ environment_mark (SCM env) static size_t environment_free (SCM env) { - return (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env); + (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env); + return 0; } @@ -984,13 +985,12 @@ leaf_environment_mark (SCM env) } -static size_t +static void leaf_environment_free (SCM env) { core_environments_finalize (env); - - free (LEAF_ENVIRONMENT (env)); - return sizeof (struct leaf_environment); + scm_gc_free (LEAF_ENVIRONMENT (env), sizeof (struct leaf_environment), + "leaf environment"); } @@ -1034,7 +1034,7 @@ SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0, #define FUNC_NAME s_scm_make_leaf_environment { size_t size = sizeof (struct leaf_environment); - struct leaf_environment *body = scm_must_malloc (size, FUNC_NAME); + struct leaf_environment *body = scm_gc_malloc (size, "leaf environment"); SCM env; core_environments_preinit (&body->base); @@ -1345,13 +1345,12 @@ eval_environment_mark (SCM env) } -static size_t +static void eval_environment_free (SCM env) { core_environments_finalize (env); - - free (EVAL_ENVIRONMENT (env)); - return sizeof (struct eval_environment); + scm_gc_free (EVAL_ENVIRONMENT (env), sizeof (struct eval_environment), + "eval environment"); } @@ -1428,7 +1427,7 @@ SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0, SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME); SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME); - body = scm_must_malloc (sizeof (struct eval_environment), FUNC_NAME); + body = scm_gc_malloc (sizeof (struct eval_environment), "eval environment"); core_environments_preinit (&body->base); body->obarray = SCM_BOOL_F; @@ -1764,13 +1763,12 @@ import_environment_mark (SCM env) } -static size_t +static void import_environment_free (SCM env) { core_environments_finalize (env); - - free (IMPORT_ENVIRONMENT (env)); - return sizeof (struct import_environment); + scm_gc_free (IMPORT_ENVIRONMENT (env), sizeof (struct import_environment), + "import environment"); } @@ -1844,7 +1842,7 @@ SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0, #define FUNC_NAME s_scm_make_import_environment { size_t size = sizeof (struct import_environment); - struct import_environment *body = scm_must_malloc (size, FUNC_NAME); + struct import_environment *body = scm_gc_malloc (size, "import environment"); SCM env; core_environments_preinit (&body->base); @@ -2070,13 +2068,12 @@ export_environment_mark (SCM env) } -static size_t +static void export_environment_free (SCM env) { core_environments_finalize (env); - - free (EXPORT_ENVIRONMENT (env)); - return sizeof (struct export_environment); + scm_gc_free (EXPORT_ENVIRONMENT (env), sizeof (struct export_environment), + "export environment"); } @@ -2171,7 +2168,7 @@ SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0, SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME); size = sizeof (struct export_environment); - body = scm_must_malloc (size, FUNC_NAME); + body = scm_gc_malloc (size, "export environment"); core_environments_preinit (&body->base); body->private = SCM_BOOL_F; diff --git a/libguile/environments.h b/libguile/environments.h index 5488adba6..bb6ee8a47 100644 --- a/libguile/environments.h +++ b/libguile/environments.h @@ -76,7 +76,7 @@ struct scm_environment_funcs { void (*unobserve) (SCM self, SCM token); SCM (*mark) (SCM self); - size_t (*free) (SCM self); + void (*free) (SCM self); int (*print) (SCM self, SCM port, scm_print_state *pstate); }; diff --git a/libguile/extensions.c b/libguile/extensions.c index 5200eb440..83bcee2a1 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -74,13 +74,12 @@ void scm_c_register_extension (const char *lib, const char *init, void (*func) (void *), void *data) { - extension_t *ext = scm_must_malloc (sizeof(extension_t), - "scm_register_extension"); + extension_t *ext = scm_malloc (sizeof(extension_t)); if (lib) - ext->lib = scm_must_strdup (lib); + ext->lib = scm_strdup (lib); else ext->lib = NULL; - ext->init = scm_must_strdup (init); + ext->init = scm_strdup (init); ext->func = func; ext->data = data; diff --git a/libguile/filesys.c b/libguile/filesys.c index 862579c10..15593b4e8 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -942,17 +942,17 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, char *wd; SCM result; - wd = scm_must_malloc (size, FUNC_NAME); + wd = scm_malloc (size); while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE) { - scm_must_free (wd); + free (wd); size *= 2; - wd = scm_must_malloc (size, FUNC_NAME); + wd = scm_malloc (size); } if (rv == 0) SCM_SYSERROR; result = scm_mem2string (wd, strlen (wd)); - scm_must_free (wd); + free (wd); return result; } #undef FUNC_NAME @@ -1367,17 +1367,17 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, char *buf; SCM result; SCM_VALIDATE_STRING (1, path); - buf = scm_must_malloc (size, FUNC_NAME); + buf = scm_malloc (size); while ((rv = readlink (SCM_STRING_CHARS (path), buf, size)) == size) { - scm_must_free (buf); + free (buf); size *= 2; - buf = scm_must_malloc (size, FUNC_NAME); + buf = scm_malloc (size); } if (rv == -1) SCM_SYSERROR; result = scm_mem2string (buf, rv); - scm_must_free (buf); + free (buf); return result; } #undef FUNC_NAME diff --git a/libguile/fports.c b/libguile/fports.c index 2ce9c4a0d..e4e34700f 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -111,7 +111,7 @@ scm_fport_buffer_add (SCM port, long read_size, int write_size) if (SCM_INPUT_PORT_P (port) && read_size > 0) { - pt->read_buf = scm_must_malloc (read_size, FUNC_NAME); + pt->read_buf = scm_gc_malloc (read_size, "port buffer"); pt->read_pos = pt->read_end = pt->read_buf; pt->read_buf_size = read_size; } @@ -123,7 +123,7 @@ scm_fport_buffer_add (SCM port, long read_size, int write_size) if (SCM_OUTPUT_PORT_P (port) && write_size > 0) { - pt->write_buf = scm_must_malloc (write_size, FUNC_NAME); + pt->write_buf = scm_gc_malloc (write_size, "port buffer"); pt->write_pos = pt->write_buf; pt->write_buf_size = write_size; } @@ -192,11 +192,18 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, pt = SCM_PTAB_ENTRY (port); - /* silently discards buffered chars. */ + /* silently discards buffered and put-back chars. */ + if (pt->read_buf == pt->putback_buf) + { + pt->read_buf = pt->saved_read_buf; + pt->read_pos = pt->saved_read_pos; + pt->read_end = pt->saved_read_end; + pt->read_buf_size = pt->saved_read_buf_size; + } if (pt->read_buf != &pt->shortbuf) - scm_must_free (pt->read_buf); + scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer"); if (pt->write_buf != &pt->shortbuf) - scm_must_free (pt->write_buf); + scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer"); scm_fport_buffer_add (port, csize, csize); return SCM_UNSPECIFIED; @@ -436,8 +443,7 @@ scm_fdes_to_port (int fdes, char *mode, SCM name) { scm_t_fport *fp - = (scm_t_fport *) scm_must_malloc (sizeof (scm_t_fport), - FUNC_NAME); + = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port"); fp->fdes = fdes; pt->rw_random = SCM_FDES_RANDOM_P (fdes); @@ -820,10 +826,10 @@ fport_close (SCM port) if (pt->read_buf == pt->putback_buf) pt->read_buf = pt->saved_read_buf; if (pt->read_buf != &pt->shortbuf) - scm_must_free (pt->read_buf); + scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer"); if (pt->write_buf != &pt->shortbuf) - scm_must_free (pt->write_buf); - scm_must_free ((char *) fp); + scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer"); + scm_gc_free (fp, sizeof (*fp), "file port"); return rv; } diff --git a/libguile/gc.c b/libguile/gc.c index 8abe7f5e0..86a1a918d 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -241,8 +241,8 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will * trigger a GC. * - * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be - * reclaimed by a GC triggered by must_malloc. If less than this is + * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must + * be reclaimed by a GC triggered by a malloc. If less than this is * reclaimed, the trigger threshold is raised. [I don't know what a * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to * work around a oscillation that caused almost constant GC.] @@ -1635,15 +1635,17 @@ scm_gc_sweep () unsigned long int length = SCM_VECTOR_LENGTH (scmptr); if (length > 0) { - m += length * sizeof (scm_t_bits); - scm_must_free (SCM_VECTOR_BASE (scmptr)); + scm_gc_free (SCM_VECTOR_BASE (scmptr), + length * sizeof (scm_t_bits), + "vector"); } break; } #ifdef CCLO case scm_tc7_cclo: - m += (SCM_CCLO_LENGTH (scmptr) * sizeof (SCM)); - scm_must_free (SCM_CCLO_BASE (scmptr)); + scm_gc_free (SCM_CCLO_BASE (scmptr), + SCM_CCLO_LENGTH (scmptr) * sizeof (SCM), + "compiled closure"); break; #endif #ifdef HAVE_ARRAYS @@ -1652,8 +1654,10 @@ scm_gc_sweep () unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr); if (length > 0) { - m += sizeof (long) * ((length + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - scm_must_free (SCM_BITVECTOR_BASE (scmptr)); + scm_gc_free (SCM_BITVECTOR_BASE (scmptr), + (sizeof (long) + * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)), + "vector"); } } break; @@ -1667,17 +1671,19 @@ scm_gc_sweep () case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: - m += SCM_UVECTOR_LENGTH (scmptr) * scm_uniform_element_size (scmptr); - scm_must_free (SCM_UVECTOR_BASE (scmptr)); + scm_gc_free (SCM_UVECTOR_BASE (scmptr), + (SCM_UVECTOR_LENGTH (scmptr) + * scm_uniform_element_size (scmptr)), + "vector"); break; #endif case scm_tc7_string: - m += SCM_STRING_LENGTH (scmptr) + 1; - scm_must_free (SCM_STRING_CHARS (scmptr)); + scm_gc_free (SCM_STRING_CHARS (scmptr), + SCM_STRING_LENGTH (scmptr) + 1, "string"); break; case scm_tc7_symbol: - m += SCM_SYMBOL_LENGTH (scmptr) + 1; - scm_must_free (SCM_SYMBOL_CHARS (scmptr)); + scm_gc_free (SCM_SYMBOL_CHARS (scmptr), + SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol"); break; case scm_tc7_variable: break; @@ -1688,6 +1694,7 @@ scm_gc_sweep () if SCM_OPENP (scmptr) { int k = SCM_PTOBNUM (scmptr); + size_t mm; #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) if (!(k < scm_numptob)) SCM_MISC_ERROR ("undefined port type", SCM_EOL); @@ -1698,7 +1705,19 @@ scm_gc_sweep () /* Yes, I really do mean scm_ptobs[k].free */ /* rather than ftobs[k].close. .close */ /* is for explicit CLOSE-PORT by user */ - m += (scm_ptobs[k].free) (scmptr); + mm = scm_ptobs[k].free (scmptr); + + if (mm != 0) + { + scm_c_issue_deprecation_warning + ("Returning non-0 from a port free function is " + "deprecated. Use scm_gc_free et al instead."); + scm_c_issue_deprecation_warning_fmt + ("(You just returned non-0 while freeing a %s.)", + SCM_PTOBNAME (k)); + m += mm; + } + SCM_SETSTREAM (scmptr, 0); scm_remove_from_port_table (scmptr); scm_gc_ports_collected++; @@ -1713,13 +1732,14 @@ scm_gc_sweep () break; #ifdef SCM_BIGDIG case scm_tc16_big: - m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); - scm_must_free (SCM_BDIGITS (scmptr)); + scm_gc_free (SCM_BDIGITS (scmptr), + ((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG + / SCM_CHAR_BIT)), "bignum"); break; #endif /* def SCM_BIGDIG */ case scm_tc16_complex: - m += sizeof (scm_t_complex); - scm_must_free (SCM_COMPLEX_MEM (scmptr)); + scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double), + "complex"); break; default: { @@ -1730,7 +1750,20 @@ scm_gc_sweep () SCM_MISC_ERROR ("undefined smob type", SCM_EOL); #endif if (scm_smobs[k].free) - m += (scm_smobs[k].free) (scmptr); + { + size_t mm; + mm = scm_smobs[k].free (scmptr); + if (mm != 0) + { + scm_c_issue_deprecation_warning + ("Returning non-0 from a smob free function is " + "deprecated. Use scm_gc_free et al instead."); + scm_c_issue_deprecation_warning_fmt + ("(You just returned non-0 while freeing a %s.)", + SCM_SMOBNAME (k)); + m += mm; + } + } break; } } @@ -1814,7 +1847,141 @@ scm_gc_sweep () -/* {Front end to malloc} +/* Function for non-cell memory management. + */ + +void * +scm_malloc (size_t size) +{ + void *ptr; + + if (size == 0) + return NULL; + + SCM_SYSCALL (ptr = malloc (size)); + if (ptr) + return ptr; + + scm_igc ("malloc"); + SCM_SYSCALL (ptr = malloc (size)); + if (ptr) + return ptr; + + scm_memory_error ("malloc"); +} + +void * +scm_realloc (void *mem, size_t size) +{ + void *ptr; + + SCM_SYSCALL (ptr = realloc (mem, size)); + if (ptr) + return ptr; + + scm_igc ("realloc"); + SCM_SYSCALL (ptr = realloc (mem, size)); + if (ptr) + return ptr; + + scm_memory_error ("realloc"); +} + +char * +scm_strndup (const char *str, size_t n) +{ + char *dst = scm_malloc (n+1); + memcpy (dst, str, n); + dst[n] = 0; + return dst; +} + +char * +scm_strdup (const char *str) +{ + return scm_strndup (str, strlen (str)); +} + +void +scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) +{ + scm_mallocated += size; + + if (scm_mallocated > scm_mtrigger) + { + scm_igc (what); + if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) + { + if (scm_mallocated > scm_mtrigger) + scm_mtrigger = scm_mallocated + scm_mallocated / 2; + else + scm_mtrigger += scm_mtrigger / 2; + } + } + +#ifdef GUILE_DEBUG_MALLOC + scm_malloc_register (mem, what); +#endif +} + +void +scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what) +{ + scm_mallocated -= size; + +#ifdef GUILE_DEBUG_MALLOC + scm_malloc_unregister (mem); +#endif +} + +void * +scm_gc_malloc (size_t size, const char *what) +{ + /* XXX - The straightforward implementation below has the problem + that it might call the GC twice, once in scm_malloc and then + again in scm_gc_register_collectable_memory. We don't really + want the second GC. + */ + + void *ptr = scm_malloc (size); + scm_gc_register_collectable_memory (ptr, size, what); + return ptr; +} + +void * +scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what) +{ + /* XXX - see scm_gc_malloc. */ + + void *ptr = scm_realloc (mem, new_size); + scm_gc_unregister_collectable_memory (mem, old_size, what); + scm_gc_register_collectable_memory (ptr, new_size, what); + return ptr; +} + +void +scm_gc_free (void *mem, size_t size, const char *what) +{ + scm_gc_unregister_collectable_memory (mem, size, what); + free (mem); +} + +char * +scm_gc_strndup (const char *str, size_t n, const char *what) +{ + char *dst = scm_gc_malloc (n+1, what); + memcpy (dst, str, n); + dst[n] = 0; + return dst; +} + +char * +scm_gc_strdup (const char *str, const char *what) +{ + return scm_gc_strndup (str, strlen (str), what); +} + +/* {Deprecated front end to malloc} * * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, * scm_done_free @@ -2660,7 +2827,7 @@ scm_init_storage () j = SCM_HEAP_SEG_SIZE; scm_mtrigger = SCM_INIT_MALLOC_LIMIT; scm_heap_table = ((scm_t_heap_seg_data *) - scm_must_malloc (sizeof (scm_t_heap_seg_data) * 2, "hplims")); + scm_malloc (sizeof (scm_t_heap_seg_data) * 2)); heap_segment_table_size = 2; mark_space_ptr = &mark_space_head; diff --git a/libguile/gc.h b/libguile/gc.h index 7cfc996f5..48a8d8d31 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -326,6 +326,22 @@ SCM_API void scm_gc_mark_dependencies (SCM p); SCM_API void scm_mark_locations (SCM_STACKITEM x[], unsigned long n); SCM_API int scm_cellp (SCM value); SCM_API void scm_gc_sweep (void); + +SCM_API void *scm_malloc (size_t size); +SCM_API void *scm_realloc (void *mem, size_t size); +SCM_API char *scm_strdup (const char *str); +SCM_API char *scm_strndup (const char *str, size_t n); +SCM_API void scm_gc_register_collectable_memory (void *mem, size_t size, + const char *what); +SCM_API void scm_gc_unregister_collectable_memory (void *mem, size_t size, + const char *what); +SCM_API void *scm_gc_malloc (size_t size, const char *what); +SCM_API void *scm_gc_realloc (void *mem, size_t old_size, + size_t new_size, const char *what); +SCM_API void scm_gc_free (void *mem, size_t size, const char *what); +SCM_API char *scm_gc_strdup (const char *str, const char *what); +SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what); + SCM_API void * scm_must_malloc (size_t len, const char *what); SCM_API void * scm_must_realloc (void *where, size_t olen, size_t len, diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 738eeb687..ceef34db0 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -155,7 +155,7 @@ makvect (char *m, size_t len, int type) SCM gh_chars2byvect (const char *d, long n) { - char *m = scm_must_malloc (n * sizeof (char), "vector"); + char *m = scm_gc_malloc (n * sizeof (char), "vector"); memcpy (m, d, n * sizeof (char)); return makvect (m, n, scm_tc7_byvect); } @@ -163,7 +163,7 @@ gh_chars2byvect (const char *d, long n) SCM gh_shorts2svect (const short *d, long n) { - char *m = scm_must_malloc (n * sizeof (short), "vector"); + char *m = scm_gc_malloc (n * sizeof (short), "vector"); memcpy (m, d, n * sizeof (short)); return makvect (m, n, scm_tc7_svect); } @@ -171,7 +171,7 @@ gh_shorts2svect (const short *d, long n) SCM gh_longs2ivect (const long *d, long n) { - char *m = scm_must_malloc (n * sizeof (long), "vector"); + char *m = scm_gc_malloc (n * sizeof (long), "vector"); memcpy (m, d, n * sizeof (long)); return makvect (m, n, scm_tc7_ivect); } @@ -179,7 +179,7 @@ gh_longs2ivect (const long *d, long n) SCM gh_ulongs2uvect (const unsigned long *d, long n) { - char *m = scm_must_malloc (n * sizeof (unsigned long), "vector"); + char *m = scm_gc_malloc (n * sizeof (unsigned long), "vector"); memcpy (m, d, n * sizeof (unsigned long)); return makvect (m, n, scm_tc7_uvect); } @@ -187,7 +187,7 @@ gh_ulongs2uvect (const unsigned long *d, long n) SCM gh_floats2fvect (const float *d, long n) { - char *m = scm_must_malloc (n * sizeof (float), "vector"); + char *m = scm_gc_malloc (n * sizeof (float), "vector"); memcpy (m, d, n * sizeof (float)); return makvect (m, n, scm_tc7_fvect); } @@ -195,7 +195,7 @@ gh_floats2fvect (const float *d, long n) SCM gh_doubles2dvect (const double *d, long n) { - char *m = scm_must_malloc (n * sizeof (double), "vector"); + char *m = scm_gc_malloc (n * sizeof (double), "vector"); memcpy (m, d, n * sizeof (double)); return makvect (m, n, scm_tc7_dvect); } diff --git a/libguile/goops.c b/libguile/goops.c index a3b179c72..5c9e0f99b 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -495,7 +495,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", scm_list_1 (nfields)); - s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0; + s = n > 0 ? scm_malloc (n) : 0; for (i = 0; i < n; i += 2) { long len; @@ -544,7 +544,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, } SCM_SET_SLOT (class, scm_si_layout, scm_mem2symbol (s, n)); if (s) - scm_must_free (s); + free (s); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -577,7 +577,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, long n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); #if 0 /* - * We could avoid calling scm_must_malloc in the allocation code + * We could avoid calling scm_gc_malloc in the allocation code * (in which case the following two lines are needed). Instead * we make 0-slot instances non-light, so that the light case * can be handled without special cases. @@ -1326,7 +1326,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT) { n = SCM_INUM (SCM_SLOT (class, scm_si_nfields)); - m = (SCM *) scm_must_malloc (n * sizeof (SCM), "instance"); + m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct"); return wrap_init (class, m, n); } @@ -1339,9 +1339,8 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, /* Entities */ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY) { - m = (SCM *) scm_alloc_struct (n, - scm_struct_entity_n_extra_words, - "entity"); + m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words, + "entity struct"); m[scm_struct_i_setter] = SCM_BOOL_F; m[scm_struct_i_procedure] = SCM_BOOL_F; /* Generic functions */ @@ -1377,9 +1376,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, /* Non-light instances */ { - m = (SCM *) scm_alloc_struct (n, - scm_struct_n_extra_words, - "heavy instance"); + m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct"); return wrap_init (class, m, n); } } @@ -1504,7 +1501,7 @@ go_to_hell (void *o) if (n_hell == hell_size) { long new_size = 2 * hell_size; - hell = scm_must_realloc (hell, hell_size, new_size, "hell"); + hell = scm_realloc (hell, new_size); hell_size = new_size; } hell[n_hell++] = SCM_STRUCT_DATA (obj); @@ -2683,7 +2680,7 @@ scm_init_goops_builtins (void) list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method)); - hell = scm_must_malloc (hell_size, "hell"); + hell = scm_malloc (hell_size); #ifdef USE_THREADS scm_mutex_init (&hell_mutex); #endif diff --git a/libguile/guardians.c b/libguile/guardians.c index d9eb5f003..88a6a4593 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -175,8 +175,8 @@ guardian_mark (SCM ptr) static size_t guardian_free (SCM ptr) { - scm_must_free (GUARDIAN_DATA (ptr)); - return sizeof (t_guardian); + scm_gc_free (GUARDIAN_DATA (ptr), sizeof (t_guardian), "guardian"); + return 0; } @@ -330,7 +330,7 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, "paper still (mostly) accurately describes the interface).") #define FUNC_NAME s_scm_make_guardian { - t_guardian *g = SCM_MUST_MALLOC_TYPE (t_guardian); + t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian"); SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL); SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL); SCM z; diff --git a/libguile/hooks.c b/libguile/hooks.c index 3fd45960e..02bd96d56 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -77,8 +77,7 @@ scm_c_hook_add (scm_t_c_hook *hook, void *func_data, int appendp) { - scm_t_c_hook_entry *entry = scm_must_malloc (sizeof (scm_t_c_hook_entry), - "C level hook entry"); + scm_t_c_hook_entry *entry = scm_malloc (sizeof (scm_t_c_hook_entry)); scm_t_c_hook_entry **loc = &hook->first; if (appendp) while (*loc) @@ -101,7 +100,7 @@ scm_c_hook_remove (scm_t_c_hook *hook, { scm_t_c_hook_entry *entry = *loc; *loc = (*loc)->next; - scm_must_free (entry); + free (entry); return; } loc = &(*loc)->next; diff --git a/libguile/init.c b/libguile/init.c index b732165b4..71d737e45 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -180,7 +180,7 @@ start_stack (void *base) /* Create an object to hold the root continuation. */ { - scm_t_contregs *contregs = scm_must_malloc (sizeof (scm_t_contregs), + scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs), "continuation"); contregs->num_stack_items = 0; contregs->seq = 0; diff --git a/libguile/keywords.c b/libguile/keywords.c index e2eb11437..05a50676f 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -95,14 +95,13 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", SCM scm_c_make_keyword (char *s) { - char *buf = scm_must_malloc (strlen (s) + 2, "keyword"); + char *buf = scm_malloc (strlen (s) + 2); SCM symbol; buf[0] = '-'; strcpy (buf + 1, s); symbol = scm_str2symbol (buf); - scm_must_free (buf); - scm_done_free (strlen (s) + 2); + free (buf); return scm_make_keyword_from_dash_symbol (symbol); } diff --git a/libguile/load.c b/libguile/load.c index 0c8011534..83b85fef6 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -354,7 +354,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, { /* scope */ SCM result = SCM_BOOL_F; size_t buf_size = max_path_len + 1 + filename_len + max_ext_len + 1; - char *buf = SCM_MUST_MALLOC (buf_size); + char *buf = scm_malloc (buf_size); /* This simplifies the loop below a bit. */ if (SCM_NULL_OR_NIL_P (extensions)) @@ -400,8 +400,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, } end: - scm_must_free (buf); - scm_done_free (buf_size); + free (buf); SCM_ALLOW_INTS; return result; } diff --git a/libguile/numbers.c b/libguile/numbers.c index daf8d5da7..bdb6f4ca3 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1388,7 +1388,7 @@ scm_i_mkbig (size_t nlen, int sign) if (((nlen << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen) scm_memory_error (s_bignum); - base = scm_must_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum); + base = scm_gc_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum); v = scm_alloc_cell (SCM_MAKE_BIGNUM_TAG (nlen, sign), (scm_t_bits) base); return v; @@ -1424,9 +1424,9 @@ scm_i_adjbig (SCM b, size_t nlen) { SCM_BIGDIG *digits = ((SCM_BIGDIG *) - scm_must_realloc ((char *) SCM_BDIGITS (b), - (long) (SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG)), - (long) (nsiz * sizeof (SCM_BIGDIG)), s_bignum)); + scm_gc_realloc (SCM_BDIGITS (b), + SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG), + nsiz * sizeof (SCM_BIGDIG), s_bignum)); SCM_SET_BIGNUM_BASE (b, digits); SCM_SETNUMDIGS (b, nsiz, SCM_BIGSIGN (b)); @@ -2840,7 +2840,8 @@ scm_make_complex (double x, double y) return scm_make_real (x); } else { SCM z; - SCM_NEWSMOB (z, scm_tc16_complex, scm_must_malloc (2L * sizeof (double), "complex")); + SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double), + "complex")); SCM_COMPLEX_REAL (z) = x; SCM_COMPLEX_IMAG (z) = y; return z; diff --git a/libguile/ports.c b/libguile/ports.c index efeb4cf46..33c6cab89 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -124,6 +124,12 @@ end_input_default (SCM port SCM_UNUSED, int offset SCM_UNUSED) { } +static size_t +scm_port_free0 (SCM port) +{ + return 0; +} + scm_t_bits scm_make_port_type (char *name, int (*fill_input) (SCM port), @@ -142,7 +148,7 @@ scm_make_port_type (char *name, scm_ptobs[scm_numptob].name = name; scm_ptobs[scm_numptob].mark = 0; - scm_ptobs[scm_numptob].free = scm_free0; + scm_ptobs[scm_numptob].free = scm_port_free0; scm_ptobs[scm_numptob].print = scm_port_print; scm_ptobs[scm_numptob].equalp = 0; scm_ptobs[scm_numptob].close = 0; @@ -455,17 +461,15 @@ scm_add_to_port_table (SCM port) if (scm_port_table_size == scm_port_table_room) { - /* initial malloc is in gc.c. this doesn't use scm_must_malloc etc., + /* initial malloc is in gc.c. this doesn't use scm_gc_malloc etc., since it can never be freed during gc. */ - void *newt = realloc ((char *) scm_port_table, - (size_t) (sizeof (scm_t_port *) - * scm_port_table_room * 2)); - if (newt == NULL) - scm_memory_error ("scm_add_to_port_table"); + void *newt = scm_realloc ((char *) scm_port_table, + (size_t) (sizeof (scm_t_port *) + * scm_port_table_room * 2)); scm_port_table = (scm_t_port **) newt; scm_port_table_room *= 2; } - entry = (scm_t_port *) scm_must_malloc (sizeof (scm_t_port), FUNC_NAME); + entry = (scm_t_port *) scm_gc_malloc (sizeof (scm_t_port), "port"); entry->port = port; entry->entry = scm_port_table_size; @@ -498,8 +502,8 @@ scm_remove_from_port_table (SCM port) if (i >= scm_port_table_size) SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port)); if (p->putback_buf) - scm_must_free (p->putback_buf); - scm_must_free (p); + scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer"); + scm_gc_free (p, sizeof (scm_t_port), "port"); /* Since we have just freed slot i we can shrink the table by moving the last entry to that slot... */ if (i < scm_port_table_size - 1) @@ -1098,8 +1102,8 @@ scm_ungetc (int c, SCM port) { size_t new_size = pt->read_buf_size * 2; unsigned char *tmp = (unsigned char *) - scm_must_realloc (pt->putback_buf, pt->read_buf_size, new_size, - FUNC_NAME); + scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size, + "putback buffer"); pt->read_pos = pt->read_buf = pt->putback_buf = tmp; pt->read_end = pt->read_buf + pt->read_buf_size; @@ -1125,8 +1129,8 @@ scm_ungetc (int c, SCM port) if (pt->putback_buf == NULL) { pt->putback_buf - = (unsigned char *) scm_must_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE, - FUNC_NAME); + = (unsigned char *) scm_gc_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE, + "putback buffer"); pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE; } diff --git a/libguile/posix.c b/libguile/posix.c index 1ef46d1db..6e3caa587 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -232,16 +232,14 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, SCM_SYSERROR; size = ngroups * sizeof (GETGROUPS_T); - groups = scm_must_malloc (size, FUNC_NAME); + groups = scm_malloc (size); getgroups (ngroups, groups); ans = scm_c_make_vector (ngroups, SCM_UNDEFINED); while (--ngroups >= 0) SCM_VELTS (ans) [ngroups] = SCM_MAKINUM (groups [ngroups]); - scm_must_free (groups); - scm_done_free (size); - + free (groups); return ans; } #undef FUNC_NAME @@ -842,7 +840,7 @@ scm_convert_exec_args (SCM args, int argn, const char *subr) argc = scm_ilength (args); SCM_ASSERT (argc >= 0, args, argn, subr); - argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr); + argv = (char **) scm_malloc ((argc + 1) * sizeof (char *)); for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) { SCM arg = SCM_CAR (args); @@ -853,7 +851,7 @@ scm_convert_exec_args (SCM args, int argn, const char *subr) SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr); len = SCM_STRING_LENGTH (arg); src = SCM_STRING_CHARS (arg); - dst = (char *) scm_must_malloc (len + 1, subr); + dst = (char *) scm_malloc (len + 1); memcpy (dst, src, len); dst[len] = 0; argv[i] = dst; @@ -1635,23 +1633,23 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, /* 256 is for Solaris, under Linux ENAMETOOLONG is returned if not large enough. */ int len = 256, res; - char *p = scm_must_malloc (len, "gethostname"); + char *p = scm_malloc (len); SCM name; res = gethostname (p, len); while (res == -1 && errno == ENAMETOOLONG) { - p = scm_must_realloc (p, len, len * 2, "gethostname"); + p = scm_realloc (p, len * 2); len *= 2; res = gethostname (p, len); } if (res == -1) { - scm_must_free (p); + free (p); SCM_SYSERROR; } name = scm_makfrom0str (p); - scm_must_free (p); + free (p); return name; } #undef FUNC_NAME diff --git a/libguile/procs.c b/libguile/procs.c index 04db7708a..afc81cd23 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -78,10 +78,8 @@ scm_c_make_subr (const char *name, long type, SCM (*fcn) ()) { long new_size = scm_subr_table_room * 3 / 2; void *new_table - = scm_must_realloc ((char *) scm_subr_table, - sizeof (scm_t_subr_entry) * scm_subr_table_room, - sizeof (scm_t_subr_entry) * new_size, - "scm_subr_table"); + = scm_realloc ((char *) scm_subr_table, + sizeof (scm_t_subr_entry) * new_size); scm_subr_table = new_table; scm_subr_table_room = new_size; } @@ -154,7 +152,8 @@ scm_mark_subr_table () SCM scm_makcclo (SCM proc, size_t len) { - scm_t_bits *base = scm_must_malloc (len * sizeof (scm_t_bits), "compiled-closure"); + scm_t_bits *base = scm_gc_malloc (len * sizeof (scm_t_bits), + "compiled closure"); unsigned long i; SCM s; @@ -376,8 +375,7 @@ scm_init_subr_table () { scm_subr_table = ((scm_t_subr_entry *) - scm_must_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room, - "scm_subr_table")); + scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room)); } void diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 6f5b9ed11..caa4eac47 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -136,7 +136,7 @@ scm_do_read_line (SCM port, size_t *len_p) { size_t buf_len = (end + 1) - pt->read_pos; /* Allocate a buffer of the perfect size. */ - unsigned char *buf = scm_must_malloc (buf_len + 1, "%read-line"); + unsigned char *buf = scm_malloc (buf_len + 1); memcpy (buf, pt->read_pos, buf_len); pt->read_pos += buf_len; @@ -155,7 +155,7 @@ scm_do_read_line (SCM port, size_t *len_p) size_t buf_size = (len < 50) ? 60 : len * 2; /* Invariant: buf always has buf_size + 1 characters allocated; the `+ 1' is for the final '\0'. */ - unsigned char *buf = scm_must_malloc (buf_size + 1, "%read-line"); + unsigned char *buf = scm_malloc (buf_size + 1); size_t buf_len = 0; for (;;) @@ -163,8 +163,7 @@ scm_do_read_line (SCM port, size_t *len_p) if (buf_len + len > buf_size) { size_t new_size = (buf_len + len) * 2; - buf = scm_must_realloc (buf, buf_size + 1, new_size + 1, - "%read-line"); + buf = scm_realloc (buf, new_size + 1); buf_size = new_size; } @@ -197,12 +196,12 @@ scm_do_read_line (SCM port, size_t *len_p) } /* I wonder how expensive this realloc is. */ - buf = scm_must_realloc (buf, buf_size + 1, buf_len + 1, "%read-line"); + buf = scm_realloc (buf, buf_len + 1); buf[buf_len] = '\0'; *len_p = buf_len; return buf; } -} +} /* @@ -247,7 +246,6 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, term = SCM_MAKE_CHAR ('\n'); s[slen-1] = '\0'; line = scm_take_str (s, slen-1); - scm_done_free (1); SCM_INCLINE (port); } else @@ -256,7 +254,7 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, term = SCM_EOF_VAL; line = scm_take_str (s, slen); SCM_COL (port) += slen; - } + } } if (pt->rw_random) diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 3d1ef561d..3eef85454 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -95,8 +95,8 @@ static size_t regex_free (SCM obj) { regfree (SCM_RGX (obj)); - free (SCM_RGX (obj)); - return sizeof(regex_t); + scm_gc_free (SCM_RGX (obj), sizeof(regex_t), "regex"); + return 0; } @@ -202,7 +202,7 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, flag = SCM_CDR (flag); } - rx = SCM_MUST_MALLOC_TYPE (regex_t); + rx = scm_gc_malloc (sizeof(regex_t), "regex"); status = regcomp (rx, SCM_STRING_CHARS (pat), /* Make sure they're not passing REG_NOSUB; regexp-exec assumes we're getting match data. */ @@ -260,7 +260,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, nmatches = SCM_RGX(rx)->re_nsub + 1; SCM_DEFER_INTS; - matches = SCM_MUST_MALLOC_TYPE_NUM (regmatch_t,nmatches); + matches = scm_malloc (sizeof (regmatch_t) * nmatches); status = regexec (SCM_RGX (rx), SCM_STRING_CHARS (str) + offset, nmatches, matches, SCM_INUM (flags)); @@ -279,7 +279,7 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, = scm_cons (scm_long2num (matches[i].rm_so + offset), scm_long2num (matches[i].rm_eo + offset)); } - scm_must_free ((char *) matches); + free (matches); SCM_ALLOW_INTS; if (status != 0 && status != REG_NOMATCH) diff --git a/libguile/root.c b/libguile/root.c index e55c393a1..389c2247b 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -105,8 +105,8 @@ scm_make_root (SCM parent) SCM root; scm_root_state *root_state; - root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state), - "scm_make_root"); + root_state = (scm_root_state *) scm_gc_malloc (sizeof (scm_root_state), + "root state"); if (SCM_ROOTP (parent)) { memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state)); @@ -247,8 +247,8 @@ scm_internal_cwdr (scm_t_catch_body body, void *body_data, SCM_REDEFER_INTS; { - scm_t_contregs *contregs = scm_must_malloc (sizeof (scm_t_contregs), - "inferior root continuation"); + scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs), + "continuation"); contregs->num_stack_items = 0; contregs->dynenv = SCM_EOL; diff --git a/libguile/smob.c b/libguile/smob.c index 788e6a8fd..94133a797 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -107,8 +107,11 @@ scm_free0 (SCM ptr SCM_UNUSED) size_t scm_smob_free (SCM obj) { - scm_must_free ((char *) SCM_CELL_WORD_1 (obj)); - return scm_smobs[SCM_SMOBNUM (obj)].size; + long n = SCM_SMOBNUM (obj); + if (scm_smobs[n].size > 0) + scm_gc_free ((void *) SCM_CELL_WORD_1 (obj), + scm_smobs[n].size, SCM_SMOBNAME (n)); + return 0; } /* {Print} @@ -457,7 +460,7 @@ scm_make_smob (scm_t_bits tc) long n = SCM_TC2SMOBNUM (tc); size_t size = scm_smobs[n].size; scm_t_bits data = (size > 0 - ? (scm_t_bits) scm_must_malloc (size, SCM_SMOBNAME (n)) + ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n)) : 0); return scm_alloc_cell (tc, data); } diff --git a/libguile/stime.c b/libguile/stime.c index a8ba26b8b..09a22f64c 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -314,7 +314,7 @@ setzone (SCM zone, int pos, const char *subr) char *buf; SCM_ASSERT (SCM_STRINGP (zone), zone, pos, subr); - buf = scm_must_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1, subr); + buf = scm_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1); sprintf (buf, "%s=%s", tzvar, SCM_STRING_CHARS (zone)); oldenv = environ; tmpenv[0] = buf; @@ -329,7 +329,7 @@ restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED) { if (!SCM_UNBNDP (zone)) { - scm_must_free (environ[0]); + free (environ[0]); environ = oldenv; #ifdef HAVE_TZSET /* for the possible benefit of user code linked with libguile. */ @@ -378,7 +378,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, #else ptr = ""; #endif - zname = SCM_MUST_MALLOC (strlen (ptr) + 1); + zname = scm_malloc (strlen (ptr) + 1); strcpy (zname, ptr); } /* the struct is copied in case localtime and gmtime share a buffer. */ @@ -407,7 +407,8 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, result = filltime (<, zoff, zname); SCM_ALLOW_INTS; - scm_must_free (zname); + if (zname) + free (zname); return result; } #undef FUNC_NAME @@ -511,7 +512,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, #else ptr = ""; #endif - zname = SCM_MUST_MALLOC (strlen (ptr) + 1); + zname = scm_malloc (strlen (ptr) + 1); strcpy (zname, ptr); } @@ -540,7 +541,8 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, result = scm_cons (scm_long2num ((long) itime), filltime (<, zoff, zname)); SCM_ALLOW_INTS; - scm_must_free (zname); + if (zname) + free (zname); return result; } #undef FUNC_NAME @@ -590,12 +592,12 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, a zero-byte output string! Workaround is to prepend a junk character to the format string, so that valid returns are always nonzero. */ - myfmt = SCM_MUST_MALLOC (len+2); + myfmt = scm_malloc (len+2); *myfmt = 'x'; strncpy(myfmt+1, fmt, len); myfmt[len+1] = 0; - tbuf = SCM_MUST_MALLOC (size); + tbuf = scm_malloc (size); { #if !defined (HAVE_TM_ZONE) /* it seems the only way to tell non-GNU versions of strftime what @@ -632,9 +634,9 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, case. */ while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size) { - scm_must_free (tbuf); + free (tbuf); size *= 2; - tbuf = SCM_MUST_MALLOC (size); + tbuf = scm_malloc (size); } #if !defined (HAVE_TM_ZONE) @@ -647,8 +649,8 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, } result = scm_mem2string (tbuf + 1, len - 1); - scm_must_free (tbuf); - scm_must_free(myfmt); + free (tbuf); + free (myfmt); return result; } #undef FUNC_NAME diff --git a/libguile/strings.c b/libguile/strings.c index 6744a58c6..c7517626d 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -133,7 +133,7 @@ scm_take_str (char *s, size_t len) SCM_ASSERT_RANGE (2, scm_ulong2num (len), len <= SCM_STRING_MAX_LENGTH); answer = scm_alloc_cell (SCM_MAKE_STRING_TAG (len), (scm_t_bits) s); - scm_done_malloc (len + 1); + scm_gc_register_collectable_memory (s, len+1, "string"); return answer; } @@ -191,7 +191,7 @@ scm_allocate_string (size_t len) SCM_ASSERT_RANGE (1, scm_long2num (len), len <= SCM_STRING_MAX_LENGTH); - mem = (char *) scm_must_malloc (len + 1, FUNC_NAME); + mem = (char *) scm_gc_malloc (len + 1, "string"); mem[len] = 0; s = scm_alloc_cell (SCM_MAKE_STRING_TAG (len), (scm_t_bits) mem); diff --git a/libguile/struct.c b/libguile/struct.c index 9d75e43f0..a384c8647 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -306,10 +306,10 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_t_bits * -scm_alloc_struct (int n_words, int n_extra, char *who) +scm_alloc_struct (int n_words, int n_extra, const char *what) { int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7; - void * block = scm_must_malloc (size, who); + void * block = scm_gc_malloc (size, what); /* Adjust the pointer to hide the extra words. */ scm_t_bits * p = (scm_t_bits *) block + n_extra; @@ -326,36 +326,33 @@ scm_alloc_struct (int n_words, int n_extra, char *who) return p; } -size_t +void scm_struct_free_0 (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data SCM_UNUSED) { - return 0; } -size_t +void scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data) { - scm_must_free (data); - return vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK; + size_t n = vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK; + scm_gc_free (data, n, "struct"); } -size_t +void scm_struct_free_standard (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data) { size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words) * sizeof (scm_t_bits) + 7; - scm_must_free ((void *) data[scm_struct_i_ptr]); - return n; + scm_gc_free ((void *) data[scm_struct_i_ptr], n, "heavy struct"); } -size_t +void scm_struct_free_entity (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data) { size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words) * sizeof (scm_t_bits) + 7; - scm_must_free ((void *) data[scm_struct_i_ptr]); - return n; + scm_gc_free ((void *) data[scm_struct_i_ptr], n, "entity struct"); } static void * @@ -455,14 +452,14 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, { data = scm_alloc_struct (basic_size + tail_elts, scm_struct_entity_n_extra_words, - "make-struct"); + "entity struct"); data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F); data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F); } else data = scm_alloc_struct (basic_size + tail_elts, scm_struct_n_extra_words, - "make-struct"); + "struct"); handle = scm_alloc_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable)) + scm_tc3_struct), (scm_t_bits) data, 0, 0); @@ -541,7 +538,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM_DEFER_INTS; data = scm_alloc_struct (basic_size + tail_elts, scm_struct_n_extra_words, - "make-vtable-vtable"); + "struct"); handle = scm_alloc_double_cell ((scm_t_bits) data + scm_tc3_struct, (scm_t_bits) data, 0, 0); data [scm_vtable_index_layout] = SCM_UNPACK (layout); diff --git a/libguile/struct.h b/libguile/struct.h index 20687e38a..7c784b14d 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -71,7 +71,7 @@ #define scm_vtable_index_printer 2 /* A printer for this struct type. */ #define scm_vtable_offset_user 3 /* Where do user fields start? */ -typedef size_t (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data); +typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data); #define SCM_STRUCTF_MASK (0xFFF << 20) #define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */ @@ -107,11 +107,12 @@ SCM_API SCM scm_structs_to_free; -SCM_API scm_t_bits * scm_alloc_struct (int n_words, int n_extra, char * who); -SCM_API size_t scm_struct_free_0 (scm_t_bits * vtable, scm_t_bits * data); -SCM_API size_t scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data); -SCM_API size_t scm_struct_free_standard (scm_t_bits * vtable, scm_t_bits * data); -SCM_API size_t scm_struct_free_entity (scm_t_bits * vtable, scm_t_bits * data); +SCM_API scm_t_bits * scm_alloc_struct (int n_words, int n_extra, + const char *what); +SCM_API void scm_struct_free_0 (scm_t_bits * vtable, scm_t_bits * data); +SCM_API void scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data); +SCM_API void scm_struct_free_standard (scm_t_bits * vtable, scm_t_bits * data); +SCM_API void scm_struct_free_entity (scm_t_bits * vtable, scm_t_bits * data); SCM_API SCM scm_make_struct_layout (SCM fields); SCM_API SCM scm_struct_p (SCM x); SCM_API SCM scm_struct_vtable_p (SCM x); diff --git a/libguile/symbols.c b/libguile/symbols.c index 106b18fce..c6979f9a4 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -126,7 +126,8 @@ scm_mem2symbol (const char *name, size_t len) SCM slot; symbol = scm_alloc_double_cell (SCM_MAKE_SYMBOL_TAG (len), - (scm_t_bits) scm_must_strndup (name, len), + (scm_t_bits) scm_gc_strndup (name, len, + "symbol"), raw_hash, SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL))); @@ -146,7 +147,8 @@ scm_mem2uninterned_symbol (const char *name, size_t len) + SCM_T_BITS_MAX/2 + 1); return scm_alloc_double_cell (SCM_MAKE_SYMBOL_TAG (len), - (scm_t_bits) scm_must_strndup (name, len), + (scm_t_bits) scm_gc_strndup (name, len, + "symbol"), raw_hash, SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL))); @@ -291,14 +293,14 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, SCM_VALIDATE_STRING (1, prefix); len = SCM_STRING_LENGTH (prefix); if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (len + SCM_INTBUFLEN); + name = scm_malloc (len + SCM_INTBUFLEN); memcpy (name, SCM_STRING_CHARS (prefix), len); } { int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); SCM res = scm_mem2symbol (name, len + n_digits); if (name != buf) - scm_must_free (name); + free (name); return res; } } diff --git a/libguile/unif.c b/libguile/unif.c index 94107db11..4e9c572b1 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -171,7 +171,7 @@ scm_make_uve (long k, SCM prot) scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH); i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); v = scm_alloc_cell (SCM_MAKE_BITVECTOR_TAG (k), - (scm_t_bits) scm_must_malloc (i, "vector")); + (scm_t_bits) scm_gc_malloc (i, "vector")); } else v = scm_alloc_cell (SCM_MAKE_BITVECTOR_TAG (0), 0); @@ -240,7 +240,7 @@ scm_make_uve (long k, SCM prot) SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH); return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (k, type), - (scm_t_bits) scm_must_malloc (i ? i : 1, "vector")); + (scm_t_bits) scm_gc_malloc (i, "vector")); } #undef FUNC_NAME @@ -520,9 +520,9 @@ scm_make_ra (int ndim) SCM ra; SCM_DEFER_INTS; SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array, - scm_must_malloc ((sizeof (scm_t_array) + - ndim * sizeof (scm_t_array_dim)), - "array")); + scm_gc_malloc ((sizeof (scm_t_array) + + ndim * sizeof (scm_t_array_dim)), + "array")); SCM_ARRAY_V (ra) = scm_nullvect; SCM_ALLOW_INTS; return ra; @@ -2589,9 +2589,11 @@ array_mark (SCM ptr) static size_t array_free (SCM ptr) { - scm_must_free (SCM_ARRAY_MEM (ptr)); - return sizeof (scm_t_array) + - SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim); + scm_gc_free (SCM_ARRAY_MEM (ptr), + (sizeof (scm_t_array) + + SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)), + "array"); + return 0; } void diff --git a/libguile/vectors.c b/libguile/vectors.c index 5868ba4f0..c1dfe840f 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -208,7 +208,7 @@ scm_c_make_vector (unsigned long int k, SCM fill) SCM_ASSERT_RANGE (1, scm_ulong2num (k), k <= SCM_VECTOR_MAX_LENGTH); - base = scm_must_malloc (k * sizeof (scm_t_bits), FUNC_NAME); + base = scm_gc_malloc (k * sizeof (scm_t_bits), "vector"); for (j = 0; j != k; ++j) base[j] = SCM_UNPACK (fill); } diff --git a/libguile/weaks.c b/libguile/weaks.c index d5fc5a060..08d570069 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -81,7 +81,7 @@ allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller) fill = SCM_UNSPECIFIED; SCM_ASSERT_RANGE (1, size, c_size <= SCM_VECTOR_MAX_LENGTH); - base = scm_must_malloc (c_size * sizeof (scm_t_bits), FUNC_NAME); + base = scm_gc_malloc (c_size * sizeof (scm_t_bits), "weak vector"); for (j = 0; j != c_size; ++j) base[j] = SCM_UNPACK (fill); v = scm_alloc_double_cell (SCM_MAKE_VECTOR_TAG (c_size, From 6c70aef189c19d6166fd7fedff771ecc304f246c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Feb 2002 18:09:15 +0000 Subject: [PATCH 30/81] Use scm_gc_malloc/scm_malloc and scm_gc_free/free instead of scm_must_malloc and scm_must_free, as appropriate. --- srfi/srfi-14.c | 2 +- srfi/srfi-4.c | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 1f3abae7d..e16f2337f 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -99,7 +99,7 @@ make_char_set (const char * func_name) { long * p; - p = scm_must_malloc (BYTES_PER_CHARSET, func_name); + p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set"); memset (p, 0, BYTES_PER_CHARSET); SCM_RETURN_NEWSMOB (scm_tc16_charset, p); } diff --git a/srfi/srfi-4.c b/srfi/srfi-4.c index 9ecd8b167..c059707d0 100644 --- a/srfi/srfi-4.c +++ b/srfi/srfi-4.c @@ -346,8 +346,10 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate SCM_UNUSED) static size_t uvec_free (SCM uvec) { - scm_must_free (SCM_UVEC_BASE (uvec)); - return SCM_UVEC_LENGTH (uvec) * uvec_sizes[SCM_UVEC_TYPE (uvec)]; + scm_gc_free (SCM_UVEC_BASE (uvec), + SCM_UVEC_LENGTH (uvec) * uvec_sizes[SCM_UVEC_TYPE (uvec)], + "uvec"); + return 0; } @@ -363,7 +365,7 @@ make_uvec (const char * func_name, int type, int len) { void * p; - p = scm_must_malloc (len * uvec_sizes[type], func_name); + p = scm_gc_malloc (len * uvec_sizes[type], "uvec"); SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, p); } From 7c686ba857d88bb47c646559fb71701892b4ed5a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 11 Feb 2002 18:09:30 +0000 Subject: [PATCH 31/81] *** empty log message *** --- libguile/ChangeLog | 28 ++++++++++++++++++++++++++++ srfi/ChangeLog | 6 ++++++ 2 files changed, 34 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2382b8f7b..d49557b5e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,31 @@ +2002-02-11 Marius Vollmer + + * gc.h, gc.c (scm_gc_sweep): Issue deprecation warning when + non-zero is returned from a port or smob free function. + (scm_malloc, scm_realloc, scm_strndup, scm_strdup, + scm_gc_register_collectable_memory, + scm_gc_unregister_collectable_memory, scm_gc_malloc, + scm_gc_realloc, scm_gc_free, scm_gc_strndup, scm_gc_strdup): New. + + * backtrace.c, continuations.c, convert.i.c, coop-threads.c, + debug-malloc.c, dynl.c, environments.c, environments.h, + extensions.c, filesys.c, fports.c, gc.c, gc.h, gh_data.c, goops.c, + guardians.c, hooks.c, init.c, keywords.c, load.c, numbers.c, + ports.c, posix.c, procs.c, rdelim.c, regex-posix.c, root.c, + smob.c, stime.c, strings.c, struct.c, struct.h, symbols.c, unif.c, + vectors.c, weaks.c: Use scm_gc_malloc/scm_malloc and + scm_gc_free/free instead of scm_must_malloc and scm_must_free, as + appropriate. Return zero from smob and port free functions. + + * debug-malloc.c (scm_malloc_reregister): Handle "old == NULL". + + * deprecation.h, deprecation.c: Reimplemented to allow deprecation + messages while the GC is running. + (scm_c_issue_deprecation_warning_fmt): New. + + * fports.c (scm_setvbuf): Reset read buffer to saved values when + it is pointing to the putback buffer. + 2002-02-08 Thien-Thi Nguyen * gsubr.c (create_gsubr): On "too many args" error, diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 28554e78d..b201d96c9 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2002-02-11 Marius Vollmer + + * srfi-14.c, srfi-4.c: Use scm_gc_malloc/scm_malloc and + scm_gc_free/free instead of scm_must_malloc and scm_must_free, as + appropriate. + 2002-01-21 Thien-Thi Nguyen * srfi-1.scm (count1, take-while): Rewrite to be tail-recursive. From f94b652476e216c2c851a60dd26bd9446e583ecc Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 12 Feb 2002 01:57:37 +0000 Subject: [PATCH 32/81] (bin_PROGRAMS): Move `guile_filter_doc_snarfage' to `noinst_PROGRAMS'. (bin_SCRIPTS): Move all values to `noinst_SCRIPTS'; delete. (noinst_PROGRAMS, noinst_SCRIPTS): New. --- libguile/Makefile.am | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e914eee86..1fe1d47ad 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -32,7 +32,8 @@ ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_L --regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/' lib_LTLIBRARIES = libguile.la -bin_PROGRAMS = guile guile_filter_doc_snarfage +bin_PROGRAMS = guile +noinst_PROGRAMS = guile_filter_doc_snarfage guile_SOURCES = guile.c guile_LDADD = libguile.la @@ -140,7 +141,9 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ ## and not a header -- headers are included in the distribution. modinclude_DATA = scmconfig.h -bin_SCRIPTS = guile-snarf guile-doc-snarf guile-snarf-docs \ +# We can re-enable install for some of these if/when they are documented +# and people feel like maintaining them. For now, this is not the case. +noinst_SCRIPTS = guile-snarf guile-doc-snarf guile-snarf-docs \ guile-func-name-check EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ From b606945b44bb9d2dbe939cc265858479c3ed1611 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 12 Feb 2002 02:00:39 +0000 Subject: [PATCH 33/81] *** empty log message *** --- libguile/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d49557b5e..5579468af 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2002-02-11 Thien-Thi Nguyen + + * Makefile.am (bin_PROGRAMS): Move `guile_filter_doc_snarfage' + to `noinst_PROGRAMS'. + (bin_SCRIPTS): Move all values to `noinst_SCRIPTS'; delete. + (noinst_PROGRAMS, noinst_SCRIPTS): New. + 2002-02-11 Marius Vollmer * gc.h, gc.c (scm_gc_sweep): Issue deprecation warning when From cd68fcc1703ce7b62cf178af3a7f40bd15b2b2d7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Feb 2002 04:17:51 +0000 Subject: [PATCH 34/81] (AUTOMAKE_OPTIONS): Replace "gnu" with "foreign". This undoes 1.14, reverting to 1.13. --- guile-readline/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index f1fefd605..054cffbb7 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -19,7 +19,7 @@ ## to the Free Software Foundation, Inc., 59 Temple Place, Suite ## 330, Boston, MA 02111-1307 USA -AUTOMAKE_OPTIONS = gnu +AUTOMAKE_OPTIONS = foreign ## Prevent automake from adding extra -I options DEFS = @DEFS@ @EXTRA_DEFS@ From 88ac59a9e63db8c8b7e50758b430491bbf10cdbf Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Wed, 13 Feb 2002 04:20:03 +0000 Subject: [PATCH 35/81] *** empty log message *** --- guile-readline/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index fc0f8889a..8bf80cc90 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2002-02-12 Thien-Thi Nguyen + + * Makefile.am (AUTOMAKE_OPTIONS): Replace "gnu" with "foreign". + This undoes the 2002-02-08 change. + 2002-02-08 Thien-Thi Nguyen * Makefile.am (AUTOMAKE_OPTIONS): Replace "foreign" with "gnu". From 738fe02a13add93959470048059683638e34660b Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 13 Feb 2002 21:50:55 +0000 Subject: [PATCH 36/81] * Fix handling of Elisp variables that are imported from other modules. --- lang/elisp/ChangeLog | 16 ++++++++++++++++ lang/elisp/base.scm | 7 ++++++- lang/elisp/internals/set.scm | 4 +++- lang/elisp/primitives/syntax.scm | 11 +++++------ lang/elisp/transform.scm | 19 ++++++++++++++----- 5 files changed, 44 insertions(+), 13 deletions(-) diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index c30491159..9f28738b0 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,19 @@ +2002-02-13 Neil Jerram + + * base.scm (load-emacs): Add optional parameters for specifying an + alternative load path, and for debugging this. (Thanks to + Thien-Thi Nguyen!) + + * primitives/syntax.scm (setq): Use `set'. + + * internals/set.scm (set): Fixed to support variables that are + imported from other modules. + +2002-02-12 Neil Jerram + + * transform.scm (scheme): Use set-current-module to ensure + expected behaviour of resolve-module. + 2002-02-08 Neil Jerram * STATUS: New file. diff --git a/lang/elisp/base.scm b/lang/elisp/base.scm index 31bd759f7..8d145c43d 100644 --- a/lang/elisp/base.scm +++ b/lang/elisp/base.scm @@ -35,7 +35,12 @@ ;;; Everything below here is written in Elisp. -(defun load-emacs () +(defun load-emacs (&optional new-load-path debug) + (if debug (message "load-path: %s" load-path)) + (cond (new-load-path + (message "Setting load-path to: %s" new-load-path) + (setq load-path new-load-path))) + (if debug (message "load-path: %s" load-path)) (scheme (read-set! keywords 'prefix)) (message "Calling loadup.el to clothe the bare Emacs...") (load "loadup.el") diff --git a/lang/elisp/internals/set.scm b/lang/elisp/internals/set.scm index 8137a6221..5e5b0048c 100644 --- a/lang/elisp/internals/set.scm +++ b/lang/elisp/internals/set.scm @@ -5,7 +5,9 @@ ;; Set SYM's variable value to VAL, and return VAL. (define (set sym val) - (module-define! the-elisp-module sym val) + (if (module-defined? the-elisp-module sym) + (module-set! the-elisp-module sym val) + (module-define! the-elisp-module sym val)) val) ;; Return SYM's variable value. If it has none, signal an error if diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index a597cd06a..6babb3dd3 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -2,6 +2,7 @@ #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals lambda) + #:use-module (lang elisp internals set) #:use-module (lang elisp internals trace) #:use-module (lang elisp transform)) @@ -13,13 +14,11 @@ (define (setq exp env) (cons begin - (let loop ((sets (cdr exp)) (last-sym #f)) + (let loop ((sets (cdr exp))) (if (null? sets) - (list last-sym) - (cons `(,module-define! ,the-elisp-module - (,quote ,(car sets)) - ,(transformer (cadr sets))) - (loop (cddr sets) (car sets))))))) + '() + (cons `(,set (,quote ,(car sets)) ,(transformer (cadr sets))) + (loop (cddr sets))))))) (fset 'setq (procedure->memoizing-macro setq)) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index f594c10cb..ee288a722 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -27,12 +27,21 @@ (error "Syntax error in expression" x)) (define-macro (scheme exp . module) - (let ((m (resolve-module (if (null? module) - '(guile-user) - (car 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) + ;;(write x) + ;;(newline) x))) (define (transformer x) From cd413a029c387fc51ae6abb0157ec37288c8b666 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Feb 2002 15:30:07 +0000 Subject: [PATCH 37/81] Added scm_must_malloc deprecation stuff. --- TODO | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/TODO b/TODO index 381b941e2..905253d91 100644 --- a/TODO +++ b/TODO @@ -107,4 +107,12 @@ that user-visible changes are reflected in NEWS. their support staffing scm_deprecated_newcell, scm_deprecated_newcell2, scm_tc16_allocated, mark_allocated. +- in gc.c and gc.h: + Remove deprecated functions scm_must_malloc, + scm_must_realloc, scm_must_free, scm_done_malloc, scm_done_free, + scm_must_strndup, scm_must_strdup. + +- Change return types of smob and port free functions to void. + They should all return zero by now. + [TODO ends here] From 539b08a4c767e5241d2b0029813661268c139c8f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Feb 2002 15:32:12 +0000 Subject: [PATCH 38/81] (scm_must_malloc, scm_must_realloc, scm_must_strdup, scm_must_strndup, scm_done_malloc, scm_done_free, scm_must_free): Reimplemented using the new scm_gc_malloc, etc., functions and deprecated. --- libguile/gc.c | 240 ++++++++++---------------------------------------- libguile/gc.h | 19 ++-- 2 files changed, 57 insertions(+), 202 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 86a1a918d..82bc71e4e 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -359,7 +359,7 @@ scm_t_freelist scm_master_freelist2 = { }; /* scm_mtrigger - * is the number of bytes of must_malloc allocation needed to trigger gc. + * is the number of bytes of malloc allocation needed to trigger gc. */ unsigned long scm_mtrigger; @@ -1920,7 +1920,8 @@ scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) } #ifdef GUILE_DEBUG_MALLOC - scm_malloc_register (mem, what); + if (mem) + scm_malloc_register (mem, what); #endif } @@ -1930,7 +1931,8 @@ scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what) scm_mallocated -= size; #ifdef GUILE_DEBUG_MALLOC - scm_malloc_unregister (mem); + if (mem) + scm_malloc_unregister (mem); #endif } @@ -1940,7 +1942,7 @@ scm_gc_malloc (size_t size, const char *what) /* XXX - The straightforward implementation below has the problem that it might call the GC twice, once in scm_malloc and then again in scm_gc_register_collectable_memory. We don't really - want the second GC. + want the second GC since it will not find new garbage. */ void *ptr = scm_malloc (size); @@ -1981,6 +1983,8 @@ scm_gc_strdup (const char *str, const char *what) return scm_gc_strndup (str, strlen (str), what); } +#if SCM_ENABLE_DEPRECATED == 1 + /* {Deprecated front end to malloc} * * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, @@ -1990,166 +1994,67 @@ scm_gc_strdup (const char *str, const char *what) * free. They should be used when allocating memory that will be under * control of the garbage collector, i.e., if the memory may be freed * during garbage collection. + * + * They are deprecated because they weren't really used the way + * outlined above, and making sure to return the right amount from + * smob free routines was sometimes difficult when dealing with nested + * data structures. We basically want everybody to review their code + * and use the more symmetrical scm_gc_malloc/scm_gc_free functions + * instead. In some cases, where scm_must_malloc has been used + * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free. */ -/* scm_must_malloc - * Return newly malloced storage or throw an error. - * - * The parameter WHAT is a string for error reporting. - * If the threshold scm_mtrigger will be passed by this - * allocation, or if the first call to malloc fails, - * garbage collect -- on the presumption that some objects - * using malloced storage may be collected. - * - * The limit scm_mtrigger may be raised by this allocation. - */ void * scm_must_malloc (size_t size, const char *what) { - void *ptr; - unsigned long nm = scm_mallocated + size; + scm_c_issue_deprecation_warning + ("scm_must_malloc is deprecated. " + "Use scm_gc_malloc and scm_gc_free instead."); - if (nm < size) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); - - if (nm <= scm_mtrigger) - { - SCM_SYSCALL (ptr = malloc (size)); - if (NULL != ptr) - { - scm_mallocated = nm; -#ifdef GUILE_DEBUG_MALLOC - scm_malloc_register (ptr, what); -#endif - return ptr; - } - } - - scm_igc (what); - - nm = scm_mallocated + size; - - if (nm < size) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); - - SCM_SYSCALL (ptr = malloc (size)); - if (NULL != ptr) - { - scm_mallocated = nm; - - if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - unsigned long old_trigger = scm_mtrigger; - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; - else - scm_mtrigger += scm_mtrigger / 2; - if (scm_mtrigger < old_trigger) - abort (); - } -#ifdef GUILE_DEBUG_MALLOC - scm_malloc_register (ptr, what); -#endif - - return ptr; - } - - scm_memory_error (what); + return scm_gc_malloc (size, what); } - -/* scm_must_realloc - * is similar to scm_must_malloc. - */ void * scm_must_realloc (void *where, size_t old_size, size_t size, const char *what) { - void *ptr; - unsigned long nm; + scm_c_issue_deprecation_warning + ("scm_must_realloc is deprecated. " + "Use scm_gc_realloc and scm_gc_free instead."); - if (size <= old_size) - return where; - - nm = scm_mallocated + size - old_size; - - if (nm < (size - old_size)) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); - - if (nm <= scm_mtrigger) - { - SCM_SYSCALL (ptr = realloc (where, size)); - if (NULL != ptr) - { - scm_mallocated = nm; -#ifdef GUILE_DEBUG_MALLOC - scm_malloc_reregister (where, ptr, what); -#endif - return ptr; - } - } - - scm_igc (what); - - nm = scm_mallocated + size - old_size; - - if (nm < (size - old_size)) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); - - SCM_SYSCALL (ptr = realloc (where, size)); - if (NULL != ptr) - { - scm_mallocated = nm; - if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - unsigned long old_trigger = scm_mtrigger; - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; - else - scm_mtrigger += scm_mtrigger / 2; - if (scm_mtrigger < old_trigger) - abort (); - } -#ifdef GUILE_DEBUG_MALLOC - scm_malloc_reregister (where, ptr, what); -#endif - return ptr; - } - - scm_memory_error (what); + return scm_gc_realloc (where, old_size, size, what); } char * scm_must_strndup (const char *str, size_t length) { - char * dst = scm_must_malloc (length + 1, "scm_must_strndup"); - memcpy (dst, str, length); - dst[length] = 0; - return dst; + scm_c_issue_deprecation_warning + ("scm_must_strndup is deprecated. " + "Use scm_gc_strndup and scm_gc_free instead."); + + return scm_gc_strndup (str, length, "string"); } char * scm_must_strdup (const char *str) { - return scm_must_strndup (str, strlen (str)); + scm_c_issue_deprecation_warning + ("scm_must_strdup is deprecated. " + "Use scm_gc_strdup and scm_gc_free instead."); + + return scm_gc_strdup (str, "string"); } void scm_must_free (void *obj) #define FUNC_NAME "scm_must_free" { + scm_c_issue_deprecation_warning + ("scm_must_free is deprecated. " + "Use scm_gc_malloc and scm_gc_free instead."); + #ifdef GUILE_DEBUG_MALLOC scm_malloc_unregister (obj); #endif @@ -2161,78 +2066,27 @@ scm_must_free (void *obj) #undef FUNC_NAME -/* Announce that there has been some malloc done that will be freed - * during gc. A typical use is for a smob that uses some malloced - * memory but can not get it from scm_must_malloc (for whatever - * reason). When a new object of this smob is created you call - * scm_done_malloc with the size of the object. When your smob free - * function is called, be sure to include this size in the return - * value. - * - * If you can't actually free the memory in the smob free function, - * for whatever reason (like reference counting), you still can (and - * should) report the amount of memory freed when you actually free it. - * Do it by calling scm_done_malloc with the _negated_ size. Clever, - * eh? Or even better, call scm_done_free. */ - void scm_done_malloc (long size) { - if (size < 0) { - if (scm_mallocated < size) - /* The byte count of allocated objects has underflowed. This is - probably because you forgot to report the sizes of objects you - have allocated, by calling scm_done_malloc or some such. When - the GC freed them, it subtracted their size from - scm_mallocated, which underflowed. */ - abort (); - } else { - unsigned long nm = scm_mallocated + size; - if (nm < size) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); - } + scm_c_issue_deprecation_warning + ("scm_done_malloc is deprecated. " + "Use scm_gc_register_collectable_memory instead."); - scm_mallocated += size; - - if (scm_mallocated > scm_mtrigger) - { - scm_igc ("foreign mallocs"); - if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) - { - if (scm_mallocated > scm_mtrigger) - scm_mtrigger = scm_mallocated + scm_mallocated / 2; - else - scm_mtrigger += scm_mtrigger / 2; - } - } + scm_gc_register_collectable_memory (NULL, size, "foreign mallocs"); } void scm_done_free (long size) { - if (size >= 0) { - if (scm_mallocated < size) - /* The byte count of allocated objects has underflowed. This is - probably because you forgot to report the sizes of objects you - have allocated, by calling scm_done_malloc or some such. When - the GC freed them, it subtracted their size from - scm_mallocated, which underflowed. */ - abort (); - } else { - unsigned long nm = scm_mallocated - size; - if (nm < size) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); - } + scm_c_issue_deprecation_warning + ("scm_done_free is deprecated. " + "Use scm_gc_unregister_collectable_memory instead."); - scm_mallocated -= size; + scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs"); } +#endif /* SCM_ENABLE_DEPRECATED == 1 */ /* {Heap Segments} diff --git a/libguile/gc.h b/libguile/gc.h index 48a8d8d31..7d575bc96 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -342,15 +342,6 @@ SCM_API void scm_gc_free (void *mem, size_t size, const char *what); SCM_API char *scm_gc_strdup (const char *str, const char *what); SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what); -SCM_API void * scm_must_malloc (size_t len, const char *what); -SCM_API void * scm_must_realloc (void *where, - size_t olen, size_t len, - const char *what); -SCM_API char *scm_must_strdup (const char *str); -SCM_API char *scm_must_strndup (const char *str, size_t n); -SCM_API void scm_done_malloc (long size); -SCM_API void scm_done_free (long size); -SCM_API void scm_must_free (void *obj); SCM_API void scm_remember_upto_here_1 (SCM obj); SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2); SCM_API void scm_remember_upto_here (SCM obj1, ...); @@ -377,6 +368,16 @@ SCM_API SCM scm_deprecated_newcell2 (void); #define SCM_NEWCELL2(_into) \ do { _into = scm_deprecated_newcell2 (); } while (0) +SCM_API void * scm_must_malloc (size_t len, const char *what); +SCM_API void * scm_must_realloc (void *where, + size_t olen, size_t len, + const char *what); +SCM_API char *scm_must_strdup (const char *str); +SCM_API char *scm_must_strndup (const char *str, size_t n); +SCM_API void scm_done_malloc (long size); +SCM_API void scm_done_free (long size); +SCM_API void scm_must_free (void *obj); + #endif #endif /* SCM_GC_H */ From c1965d31aa2ae326fc10dac492001a20f386f69a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 14 Feb 2002 15:32:25 +0000 Subject: [PATCH 39/81] *** empty log message *** --- libguile/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 5579468af..b46f0f98a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2002-02-14 Marius Vollmer + + * gc.h, gc.c (scm_must_malloc, scm_must_realloc, scm_must_strdup, + scm_must_strndup, scm_done_malloc, scm_done_free, scm_must_free): + Reimplemented using the new scm_gc_malloc, etc., functions and + deprecated. + 2002-02-11 Thien-Thi Nguyen * Makefile.am (bin_PROGRAMS): Move `guile_filter_doc_snarfage' From ed708641b10a2b6e2b4859cc69e923b724f2bf5b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 15 Feb 2002 04:14:56 +0000 Subject: [PATCH 40/81] Initial revision --- devel/gc/README | 0 devel/gc/gc+callcc.text | 0 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 devel/gc/README create mode 100644 devel/gc/gc+callcc.text diff --git a/devel/gc/README b/devel/gc/README new file mode 100644 index 000000000..e69de29bb diff --git a/devel/gc/gc+callcc.text b/devel/gc/gc+callcc.text new file mode 100644 index 000000000..e69de29bb From 2918e43fae7efd23dfe01f6f51edc7bf5b7db429 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 15 Feb 2002 05:23:07 +0000 Subject: [PATCH 41/81] Initial revision --- devel/htbmc.text | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 devel/htbmc.text diff --git a/devel/htbmc.text b/devel/htbmc.text new file mode 100644 index 000000000..e69de29bb From 8145b8b55176f57f03ed3e10c943fb5cbd829a3f Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 15 Feb 2002 05:28:08 +0000 Subject: [PATCH 42/81] Initial revision --- devel/htbmc-commentary.text | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 devel/htbmc-commentary.text diff --git a/devel/htbmc-commentary.text b/devel/htbmc-commentary.text new file mode 100644 index 000000000..d9685f2a8 --- /dev/null +++ b/devel/htbmc-commentary.text @@ -0,0 +1,9 @@ +Record your position on "how to be more careful" here. + + +* 2002/02/14 21:21:21 ttn + +i think tom has some good points, although the formalism is a bit heavy. +definitely, digging through mailing list archives is suboptimal. once i get +1.4.1 (and .2, etc, if required) out, i'll organize an archeological dig to +get all the proper bits (and xref) locked down. From 44f31710945f1c856d7e54301bc5522f659a1aad Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 15 Feb 2002 21:29:39 +0000 Subject: [PATCH 43/81] Initial revision --- devel/build/recording-api.text | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 devel/build/recording-api.text diff --git a/devel/build/recording-api.text b/devel/build/recording-api.text new file mode 100644 index 000000000..e69de29bb From 8121c27d3e84b1bd3da4a8f285d19190a50b8e98 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 15 Feb 2002 21:38:11 +0000 Subject: [PATCH 44/81] Initial revision --- doc/guile-api.alist | 3201 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3201 insertions(+) create mode 100644 doc/guile-api.alist diff --git a/doc/guile-api.alist b/doc/guile-api.alist new file mode 100644 index 000000000..c1a6c46e1 --- /dev/null +++ b/doc/guile-api.alist @@ -0,0 +1,3201 @@ +;; Generated Fri Feb 15 13:35:09 PST 2002 by guile-scripts/scan-api -- do not edit! +;; guile: /home/ttn/build/.gnu/guile-core/pre-inst-guile . +;; sofile: libguile/.libs/libguile.so.10.0.0 + +( +(scheme +($abs "#bool "# "") +( "") +( "") +(= "# "#= "# "#list "#integer "#=? "#? "#=? "#? "#uniform-array "#fdes "#inport "#outport "#port "#inexact "#inport "#outport "#ports "#list "#exact "#char "#symbol "#keyword "#array "#string "#symbol "#uniform-array "#uniform-vector "#vector "#weak-vector "#fdes "#string "#string "#fdes "#fdes "#macro "#memoizing-macro "#syntax "#random-state "#list "#number "#symbol "#symbol "#=? "#? "#=? "#? "#keyword "#string "#") +(usleep "#list "# Date: Tue, 19 Feb 2002 22:41:18 +0000 Subject: [PATCH 45/81] (Memory Blocks): New section. --- doc/ref/scheme-memory.texi | 116 +++++++++++++++++++++++++++++++++---- 1 file changed, 105 insertions(+), 11 deletions(-) diff --git a/doc/ref/scheme-memory.texi b/doc/ref/scheme-memory.texi index 30dd2e122..45f0f883b 100644 --- a/doc/ref/scheme-memory.texi +++ b/doc/ref/scheme-memory.texi @@ -4,6 +4,7 @@ @menu * Garbage Collection:: +* Memory Blocks:: * Weak References:: * Guardians:: @end menu @@ -12,13 +13,11 @@ @node Garbage Collection @section Garbage Collection -[FIXME: this is pasted in from Tom Lord's original guile.texi and should -be reviewed] - @deffn {Scheme Procedure} gc @deffnx {C Function} scm_gc () Scans all of SCM objects and reclaims for further use those that are -no longer accessible. +no longer accessible. You normally don't need to call this function +explicitely. It is called automatically when appropriate. @end deffn @deffn {Scheme Procedure} gc-stats @@ -27,18 +26,113 @@ Return an association list of statistics about Guile's current use of storage. @end deffn -@deffn {Scheme Procedure} object-address obj -@deffnx {C Function} scm_object_address (obj) -Return an integer that for the lifetime of @var{obj} is uniquely -returned by this function for @var{obj} -@end deffn +@node Memory Blocks +@section Memory Blocks + +In C programs, dynamic management of memory blocks is normally done +with the functions malloc, realloc, and free. Guile has additional +functions for dynamic memory allocation that are integrated into the +garbage collector and the error reporting system. + +Memory blocks that are associated with Scheme objects (for example a +smob) should be allocated and freed with @code{scm_gc_malloc} and +@code{scm_gc_free}. The function @code{scm_gc_malloc} will either +return a valid pointer or signal an error. It will also assume that +the new memory can be freed by a garbage collection. The garbage +collector uses this information to decide when to try to actually +collect some garbage. Memory blocks allocated with +@code{scm_gc_malloc} must be freed with @code{scm_gc_free}. + +For memory that is not associated with a Scheme object, you can use +@code{scm_malloc} instead of @code{malloc}. Like +@code{scm_gc_malloc}, it will either return a valid pointer or signal +an error. However, it will not assume that the new memory block can +be freed by a garbage collection. The memory can be freed with +@code{free}. + +There is also @code{scm_gc_realloc} and @code{scm_realloc}, to be used +in place of @code{realloc} when appropriate. + +For really specialized needs, take at look at +@code{scm_gc_register_collectable_memory} and +@code{scm_gc_unregister_collectable_memory}. + +@deftypefn {C Function} void *scm_malloc (size_t @var{size}) +Allocate @var{size} bytes of memory and return a pointer to it. When +@var{size} is 0, return @code{NULL}. When not enough memory is +available, signal an error. This function runs the GC to free up some +memory when it deems it appropriate. + +The memory is allocated by the libc @code{malloc} function and can be +freed with @code{free}. There is no @code{scm_free} function to go +with @code{scm_malloc} to make it easier to pass memory back and forth +between different modules. +@end deftypefn + +@deftypefn {C Function} void *scm_realloc (void *@var{mem}, size_t @var{new_size}) +Change the size of the memory block at @var{mem} to @var{new_size} and +return its new location. When @var{new_size} is 0, this is the same +as calling @code{free} on @var{mem} and @code{NULL} is returned. When +@var{mem} is @code{NULL}, this function behaves like @code{scm_malloc} +and allocates a new block of size @var{new_size}. + +When not enough memory is available, signal an error. This function +runs the GC to free up some memory when it deems it appropriate. +@end deftypefn + + +@deftypefn {C Function} void scm_gc_register_collectable_memory (void *@var{mem}, size_t @var{size}, const char *@var{what}) +Informs the GC that the memory at @var{mem} of size @var{size} can +potentially be freed during a GC. That is, announce that @var{mem} is +part of a GC controlled object and when the GC happens to free that +object, @var{size} bytes will be freed along with it. The GC will +@strong{not} free the memory itself, it will just know that so-and-so +much bytes of memory are associated with GC controlled objects and the +memory system figures this into its decisions when to run a GC. + +@var{mem} does not need to come from @code{scm_malloc}. You can only +call this function once for every memory block. + +The @var{what} argument is used for statistical purposes. It should +describe the type of object that the memory will be used for so that +users can identify just what strange objects are eating up their +memory. +@end deftypefn + +@deftypefn {C Function} void scm_gc_unregister_collectable_memory (void *@var{mem}, size_t @var{size}) +Informs the GC that the memory at @var{mem} of size @var{size} is no +longer associated with a GC controlled object. You must take care to +match up every call to @code{scm_gc_register_collectable_memory} with +a call to @code{scm_gc_unregister_collectable_memory}. If you don't do +this, the GC might have a wrong impression of what is going on and run +much less efficiently than it could. +@end deftypefn + + +@deftypefn {C Function} void *scm_gc_malloc (size_t @var{size}, const char *@var{what}) +@deftypefnx {C Function} void *scm_gc_realloc (void *@var{mem}, size_t @var{old_size}, size_t @var{new_size}, const char *@var{what}); +Like @code{scm_malloc} or @code{scm_realloc}, but also call +@code{scm_gc_register_collectable_memory}. Note that you need to pass +the old size of a reallocated memory block as well. See below for a +motivation. +@end deftypefn + +@deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what}) +Like @code{free}, but also call @code{scm_gc_unregister_collectable_memory}. + +Note that you need to explicitely pass the @var{size} parameter. This +is done since it should normally be easy to provide this parameter +(for memory that is associated with GC controlled objects) and this +frees us from tracking this value in the GC itself, which will keep +the memory management overhead very low. +@end deftypefn @node Weak References @section Weak References -[FIXME: This chapter is based on Mikael Djurfeldt's answer to a question -by Michael Livshin. Any mistakes are not theirs, of course. ] +[FIXME: This chapter is based on Mikael Djurfeldt's answer to a +question by Michael Livshin. Any mistakes are not theirs, of course. ] Weak references let you attach bookkeeping information to data so that the additional information automatically disappears when the original From bd75ebc37fa96f1d14c7949c7d15473887a3cc8c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 19 Feb 2002 22:41:30 +0000 Subject: [PATCH 46/81] *** empty log message *** --- doc/ref/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 4c9a21bd9..caaeb6a51 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,7 @@ +2002-02-19 Marius Vollmer + + * scheme-memory.texi (Memory Blocks): New section. + 2002-02-05 Thien-Thi Nguyen * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. From b30366b6b99b89e0aeeb23a9ed6b5f076ece48eb Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 20 Feb 2002 21:27:57 +0000 Subject: [PATCH 47/81] * Add two new bugs to BUGS file. --- BUGS | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) diff --git a/BUGS b/BUGS index d3a2ecb32..37016476c 100644 --- a/BUGS +++ b/BUGS @@ -342,5 +342,73 @@ Thomas Wawrzinek sez: > To avoid such behavior, would it be sensible to have guile indicate > a wrong usage error or something? + +bug 13 -- incorrect error reporting after stack overflow +reported-by: Panagiotis Vossos / 2002-02-19 +fixed: not-yet + +Panagiotis Vossos sez: + +I have guile 1.5.4 installed and I discovered something strange. + +guile> (define (foo n) (+ n (foo n))) +guile> (foo 10) +ERROR: Stack overflow +ABORT: (stack-overflow) +guile> thisisabug +: In expression thisisabug: +: Unbound variable: thisisabug +ABORT: (unbound-variable) +guile> (foo 10) +: In expression thisisabug: +: Stack overflow +ABORT: (stack-overflow) + +The last message shows the previous unbound variable 'thisisabug'. +'foo' is just an example, this seems to happen for every function that +causes overflow. It's not serious, but it sure looks misleading.. + +Neil Jerram sez: + +It's something to do with the way that debug info frames cope with +stack overflow. + + +bug 14 -- strange gc loop caused by trap misuse +reported-by: Neil Jerram / 2002-02-03 +fixed: not-yet + +Neil Jerram sez: + +Using the current unstable CVS Guile... + +Running under gdb, type in the following: + +(gdb) run -q +Starting program: /usr/local/bin/guile -q +guile> (trap-set! enter-frame-handler (lambda () 1)) +(exit-frame-handler #f apply-frame-handler #f enter-frame-handler # traps) +guile> (trap-enable 'enter-frame) + +There is no response. Wait a few seconds, and then C-c to send an +interrupt. You'll find that the call stack shows a huge number of +recursive calls to scm_gc_mark (about 4000 per second waited on my +box). (If you don't see scm_gc_mark immediately, you may have +interrupted too quickly: let it run for another second and then C-c +again.) + +Here's as much of an explanation as I can offer... The intended +effect of the two `trap' lines above is that the evaluator calls the +specified procedure every time it enters a new evaluation frame or is +about to perform an application. However, the procedure above doesn't +accept the right number of arguments, so the attempt to call it gives +rise to a wrong-num-args error, which (I presume) jumps us out of that +level of the evaluator and is caught by the usual REPL machinery in +boot-9.scm. + +Then, the next time that we need to GC, we hit this scm_gc_mark loop. +My guess is that something about the trap+error scenario has left data +or the stack in a state which exposes a bug in the GC. + [BUGS ends here] From c709de7f982ee19843e162f1778705a002c513c4 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 21 Feb 2002 01:00:41 +0000 Subject: [PATCH 48/81] * gc.c (scm_gc_sweep): Print an error message when aborting due to underflowing scm_mallocated. --- libguile/ChangeLog | 5 +++++ libguile/gc.c | 20 +++++++++++++------- 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b46f0f98a..80943b34e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2002-02-20 Mikael Djurfeldt + + * gc.c (scm_gc_sweep): Print an error message when aborting due to + underflowing scm_mallocated. + 2002-02-14 Marius Vollmer * gc.h, gc.c (scm_must_malloc, scm_must_realloc, scm_must_strdup, diff --git a/libguile/gc.c b/libguile/gc.c index 82bc71e4e..3c901b0dd 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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 @@ -1833,12 +1833,18 @@ scm_gc_sweep () scm_gc_yield -= scm_cells_allocated; if (scm_mallocated < m) - /* The byte count of allocated objects has underflowed. This is - probably because you forgot to report the sizes of objects you - have allocated, by calling scm_done_malloc or some such. When - the GC freed them, it subtracted their size from - scm_mallocated, which underflowed. */ - abort (); + { + /* The byte count of allocated objects has underflowed. This is + probably because you forgot to report the sizes of objects you + have allocated, by calling scm_done_malloc or some such. When + the GC freed them, it subtracted their size from + scm_mallocated, which underflowed. */ + fprintf (stderr, + "scm_gc_sweep: Byte count of allocated objects has underflowed.\n" + "This is probably because the GC hasn't been correctly informed\n" + "about object sizes\n"); + abort (); + } scm_mallocated -= m; scm_gc_malloc_collected = m; From 3d77146f52e28c143dcd2010229b09b690357452 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 21 Feb 2002 19:35:39 +0000 Subject: [PATCH 49/81] * Quote multiword string using [ ]. --- ChangeLog | 6 ++++++ acinclude.m4 | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index e43ce5fa4..7e0642ac7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2002-02-21 Neil Jerram + + * acinclude.m4 (GUILE_HEADER_LIBC_WITH_UNISTD): Use [] rather than + "" for multiword string. Thanks to Christopher Cramer for + pointing this out. + 2002-02-11 Marius Vollmer * acconfig.h (GUILE_DEBUG_MALLOC): Refer to scm_gc_malloc, etc, diff --git a/acinclude.m4 b/acinclude.m4 index f0402880a..f0ec6d03c 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -32,7 +32,7 @@ AC_DEFUN([GUILE_HEADER_LIBC_WITH_UNISTD], [ AC_CHECK_HEADERS(libc.h unistd.h) AC_CACHE_CHECK( - "whether libc.h and unistd.h can be included together", + [whether libc.h and unistd.h can be included together], guile_cv_header_libc_with_unistd, [ if test "$ac_cv_header_libc_h" = "no"; then From 848f30d0e7caa386bdbb47e8b00def7e0436c970 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 22 Feb 2002 10:51:27 +0000 Subject: [PATCH 50/81] Initial revision --- scripts/api-diff | 86 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 86 insertions(+) create mode 100755 scripts/api-diff diff --git a/scripts/api-diff b/scripts/api-diff new file mode 100755 index 000000000..76e8d8582 --- /dev/null +++ b/scripts/api-diff @@ -0,0 +1,86 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(scripts api-diff)) '\'main')' +exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; api-diff --- diff guile-api.alist files + +;; Copyright (C) 2002 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 software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA + +;;; Author: Thien-Thi Nguyen + +;;; Commentary: + +;; Usage: api-diff alist-file-A alist-file-B +;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B +;; and display four lists: old scheme, new scheme, old C, new C. +;; +;; For scheme programming, the (scripts api-diff) module exports +;; two procedures: +;; (diff-alists A-alist B-alist report) +;; (api-diff A-file B-file) +;; The latter implements the shell interface using the former. +;; REPORT is a proc that takes the above four lists. Its return +;; value is returned by `diff-alists'. +;; +;; Note that the convention is that the "older" alist/file is +;; specified first. +;; +;; TODO: When the annotations support it, also detect/report +;; procedure signature, or other simple type, changes. + +;;; Code: + +(define-module (scripts api-diff) + :use-module (ice-9 common-list) + :export (diff-alists api-diff)) + +(define (read-alist-file file) + (with-input-from-file file + (lambda () (read)))) + +(define (diff x y) (set-difference (map car x) (map car y))) + +(define (diff-alists A B report) + (let* ((A-scheme (assq-ref A 'scheme)) + (A-C (assq-ref A 'C)) + (B-scheme (assq-ref B 'scheme)) + (B-C (assq-ref B 'C)) + (OLD-scheme (diff A-scheme B-scheme)) + (NEW-scheme (diff B-scheme A-scheme)) + (OLD-C (diff A-C B-C)) + (NEW-C (diff B-C A-C))) + (report OLD-scheme NEW-scheme OLD-C NEW-C))) + +(define (display-list head ls) + (format #t ":: ~A -- ~A\n" head (length ls)) + (for-each (lambda (x) (format #t "~A\n" x)) ls) + (newline)) + +(define (api-diff . args) + (diff-alists (read-alist-file (list-ref args 0)) + (read-alist-file (list-ref args 1)) + (lambda (OLD-scheme NEW-scheme OLD-C NEW-C) + (display-list "OLD (deleted) scheme" OLD-scheme) + (display-list "NEW scheme" NEW-scheme) + (display-list "OLD (deleted) C" OLD-C) + (display-list "NEW C" NEW-C)))) + +(define main api-diff) + +;;; api-diff ends here From bf9b86fc598e2218cfd7c17fdf5a425df56f228d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Fri, 22 Feb 2002 10:52:06 +0000 Subject: [PATCH 51/81] *** empty log message *** --- scripts/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index f11df41c2..d6484894c 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,7 @@ +2002-02-22 Thien-Thi Nguyen + + * api-diff: New script. + 2002-02-05 Thien-Thi Nguyen * Include $(top_srcdir)/pre-inst-guile.am. From cd328b4fef97572b4521ba92ced5e6ddeb11ae44 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 22 Feb 2002 23:14:38 +0000 Subject: [PATCH 52/81] * Fix a typo that crept in with the scm_X_t to scm_t_X rename. * Partial fix for date-week-number bug. --- libguile/ChangeLog | 5 +++++ libguile/unif.c | 4 ++-- libguile/unif.h | 2 +- srfi/ChangeLog | 6 ++++++ srfi/srfi-19.scm | 2 +- 5 files changed, 15 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 80943b34e..c6d8dac9a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2002-02-21 Neil Jerram + + * unif.c (scm_array_to_list): Correct name, which had been + accidentally changed to scm_t_arrayo_list! + 2002-02-20 Mikael Djurfeldt * gc.c (scm_gc_sweep): Print an error message when aborting due to diff --git a/libguile/unif.c b/libguile/unif.c index 4e9c572b1..96bdfa4f0 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -2078,11 +2078,11 @@ ra2l (SCM ra,unsigned long base,unsigned long k) } -SCM_DEFINE (scm_t_arrayo_list, "array->list", 1, 0, 0, +SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, (SCM v), "Return a list consisting of all the elements, in order, of\n" "@var{array}.") -#define FUNC_NAME s_scm_t_arrayo_list +#define FUNC_NAME s_scm_array_to_list { SCM res = SCM_EOL; register long k; diff --git a/libguile/unif.h b/libguile/unif.h index 522a630b4..e467033df 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -140,7 +140,7 @@ SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); SCM_API SCM scm_bit_invert_x (SCM v); SCM_API SCM scm_istr2bve (char *str, long len); -SCM_API SCM scm_t_arrayo_list (SCM v); +SCM_API SCM scm_array_to_list (SCM v); SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); SCM_API SCM scm_array_prototype (SCM ra); diff --git a/srfi/ChangeLog b/srfi/ChangeLog index b201d96c9..f9d8659f2 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2002-02-22 Neil Jerram + + * srfi-19.scm (priv:year-day): Index into priv:month-assoc using + month number, not day number. (Thanks to Sébastien de Menten de + Horne for reporting the problem.) + 2002-02-11 Marius Vollmer * srfi-14.c, srfi-4.c: Use scm_gc_malloc/scm_malloc and diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 9b8418a99..f1ad0e7cc 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -802,7 +802,7 @@ (9 . 273) (10 . 304) (11 . 334) (12 . 365))) (define (priv:year-day day month year) - (let ((days-pr (assoc day priv:month-assoc))) + (let ((days-pr (assoc month priv:month-assoc))) (if (not days-pr) (priv:error 'date-year-day 'invalid-month-specification month)) (if (and (priv:leap-year? year) (> month 2)) From b55542ee46bb82e3cce186663d668d8e7925da85 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 23 Feb 2002 11:15:54 +0000 Subject: [PATCH 53/81] Removed Mikael by his request. --- THANKS | 1 - 1 file changed, 1 deletion(-) diff --git a/THANKS b/THANKS index 4a34e7b29..4ef8ceb73 100644 --- a/THANKS +++ b/THANKS @@ -1,6 +1,5 @@ The Guile maintainer committee consists of - Mikael Djurfeldt Marius Vollmer Contributors since the last release: From 359b471e2671d04096bd9605dc23fc89aa00374a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 23 Feb 2002 22:24:24 +0000 Subject: [PATCH 54/81] * Fix date-week-number bug in srfi-19.scm. --- srfi/ChangeLog | 5 +++++ srfi/srfi-19.scm | 8 +++++--- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index f9d8659f2..1ae9ac95d 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2002-02-23 Neil Jerram + + * srfi-19.scm (priv:month-assoc): Correct numbers so that they + match the expectations of priv:year-day. + 2002-02-22 Neil Jerram * srfi-19.scm (priv:year-day): Index into priv:month-assoc using diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index f1ad0e7cc..5f21847b4 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -797,9 +797,11 @@ (define (leap-year? date) (priv:leap-year? (date-year date))) -(define priv:month-assoc '((1 . 31) (2 . 59) (3 . 90) (4 . 120) - (5 . 151) (6 . 181) (7 . 212) (8 . 243) - (9 . 273) (10 . 304) (11 . 334) (12 . 365))) +;; Map 1-based month number M to number of days in the year before the +;; start of month M (in a non-leap year). +(define priv:month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90) + (5 . 120) (6 . 151) (7 . 181) (8 . 212) + (9 . 243) (10 . 273) (11 . 304) (12 . 334))) (define (priv:year-day day month year) (let ((days-pr (assoc month priv:month-assoc))) From d4fb8e8e43412771545896edd7a5902ecac9a401 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 24 Feb 2002 04:23:13 +0000 Subject: [PATCH 55/81] *** empty log message *** --- devel/htbmc-commentary.text | 9 --------- 1 file changed, 9 deletions(-) diff --git a/devel/htbmc-commentary.text b/devel/htbmc-commentary.text index d9685f2a8..e69de29bb 100644 --- a/devel/htbmc-commentary.text +++ b/devel/htbmc-commentary.text @@ -1,9 +0,0 @@ -Record your position on "how to be more careful" here. - - -* 2002/02/14 21:21:21 ttn - -i think tom has some good points, although the formalism is a bit heavy. -definitely, digging through mailing list archives is suboptimal. once i get -1.4.1 (and .2, etc, if required) out, i'll organize an archeological dig to -get all the proper bits (and xref) locked down. From 6735abdbd7edfc09e2a9fed23c53227cb88f92e2 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:46:08 +0000 Subject: [PATCH 56/81] * RELEASE: update release building instructions. --- RELEASE | 216 -------------------------------------------------------- 1 file changed, 216 deletions(-) diff --git a/RELEASE b/RELEASE index f1ae2e023..e69de29bb 100644 --- a/RELEASE +++ b/RELEASE @@ -1,216 +0,0 @@ --*-text-*- -This is a checklist for making Guile releases. -It's specific to the FSF's development environment; please don't put -it in the distribution. - -Maybe we should name Guile releases after entertaining poisons: -absinthe, etc. However, the first release containing the module -system should be called Godot: "This is the one you've been waiting -for." - -Platforms for test builds: -SunOS (gcc and pcc) --- galapas.ai.mit.edu -Solaris (gcc and SUN cc) --- saturn.ai.mit.edu -NetBSD (gcc) --- repo-man.ai.mit.edu (use /home/repo/jimb) -HP/UX (gcc, HP cc) --- nutrimat.gnu.ai.mit.edu - -These gentlemen have kindly offered to do pre-release testing: - -Tom Tromey : - - alphaev5-unknown-linux-gnu - hppa1.1-hp-hpux10.20 - hppa1.1-hp-hpux11.00 - mips-sgi-irix5.3 - powerpc-ibm-aix4.2.0.0 - powerpc-unknown-linux-gnu - sparc-sun-solaris2.6 - i686-pc-linux-gnu - mips-sgi-irix6.3 - sparc-sun-sunos4.1.4 - -Perry Metzger - - NetBSD - - -Release Checklists =================================================== - -There are basically three phases to doing a release: - -* "BRANCHING": Creating a stable development branch in CVS. - -* "SPIFFING": Updating NEWS, README, INSTALL. Running tests. Getting - people to try builds on various machines. Getting everything - straightened up. - -* "PUNTING": Updating the version numbers. Tagging the sources. Asking - the FSF to put the disty on ftp.gnu.org. Posting announcements. - -The "Spiffing" phase you might go through several times as you -discover problems. The "Branching" and "Punting" phases you do only -once. - -Branching checklist: - -* Announce when you're about to make the branch so that you have a - greater chance of people holding off on edits during the short - period while you're branching. - -* Make sure you're on the main trunk (see HACKING), and then create - the branch-root tag. i.e. -r branch-root_release-1-6. (Add the - exact command here next time I do it.) - -* Now create the branch with the branch tag. i.e. -r - branch_release-1-6. (Add exact command here next time I do it.) - -* Change the version numbers in GUILE-VERSION and README on the main - branch to reflect the new unstable version i.e. 1.7.0, if you're - currently creating the 1.6.X branch. - -Spiffing checklist: - -* Make sure you're working on the stable branch (see HACKING for - details). Note that after following the branch checklist above, you - won't necessarily be. - -* Check for files that have changed a lot, but do not have up-to-date - copyright notices. This can be as simple as doing: - grep 'Copyright' * | grep -v 1999 - and looking for files you know you've worked on a lot. - -* Make sure NEWS, INSTALL, AUTHORS and THANKS and the docs are up to date: - + Scan the ChangeLogs for user-visible changes, marked with an asterisk - at the left margin. - + Update NEWS and the Texinfo documentation as appropriate. - + Remove the user-visible markers from the log entries once they're - documented. - + Check for any [[incomplete]] sections of NEWS. - + Fact-check INSTALL. - + Make sure AUTHORS and THANKS are up-to-date (see also TODO). - + Remove finished items from TODO (those marked w/ "+"). - -* Make sure the downloading addresses and filenames in README are - current. (But don't bump the version number yet. We do that below.) - -* Check that the versions of aclocal, automake, autoconf, and autoheader - in your PATH match those given in HACKING. Note that the `make - dist' process always invokes these tools, even when all the - generated files are up to date. - Make specifically sure that the files in libltdl are generated using - the same tools as the rest. - -* Rebuild all generated files in the source tree: - + run ./autogen.sh - -* Verify that Guile builds and runs in your working directory. - -* Run a "make check". - -* Commit all changes to the CVS repository. - -* Build a test distribution. - - + update GUILE-VERSION each time you make a test distribution. For - example, just before the 1.6.0 release, we went through some - number of 1.5.X test releases. - - + BEFORE doing 'make dist', configure the source tree for build - in the same tree with these configuration options: - --enable-maintainer-mode - --enable-debug-malloc - --with-threads - --enable-error-on-warning - - + Make sure that readline was enabled correctly. - - + Build the tree. - (If the above steps are not done, the dependencies won't be properly - included in the generated Makefile.in files.) - - + Then do 'make dist'. - - + Check that the dependencies in guile-readline/Makefile look OK. - (We currently use a kludge which edits the dependencies generated - by automake so that Guile can be built in a directory separate - from the source tree also with non-GNU make programs.) - -* Give the test disty to various people to try. Here's what you should do: - + Unset GUILE_LOAD_PATH. - + Remove automake and autoconf from your path, or turn off their - execute bits, or something. (Users must be able to build the - disty without installing those tools.) - + Configure, make, and install. - + Make sure LD_LIBRARY_PATH doesn't include anything unnecessary. - + Run the test suite on the installed version. - + You might try the example code in the doc directory. - -Once you've got a disty that seems pretty solid: - -* Make sure the shared library libtool versioning numbers are correct, - but first make sure you understand "Libtool's versioning system" in - the libtool info pages. Guile is going to be versioning it's shared - libraries independently, so follow the libtool rules for choosing - version numbers, but make sure to keep in mind that not everyone is - as good about this as they should be. If a library even changes the - layout of a data structure that's part of it's API in a backward - incompatible way, even if that data structure is handled as an - opaque object in the API, that library is probably no longer - compatible with previous versions. - - A canonical ugly problem is this. Imagine you have libfoo and - libbar that both are linked against libbaz. Now imagine that you - create a libwhatever that uses both libfoo and libbar. What you - don't want to have happen is libfoo and libbar to be linked against - different versions of libbaz that produce incompatible instances of - the "same" data structure, and then have libwhatever get one version - of this data structure from libbaz via libfoo, and pass it back to a - different version of libbaz via libbar, a version of libbaz that - can't handle the newer/older struct from the other libbaz. - -* In general, there will be a number of libraries in guile that will - have to be versioned, and it would be best if the people who know - the most about the individual libs decide what the apropriate - CURRENT, REVISION, and AGE numbers for each one are. In general, - though, you have to be conservative. If no one is sure that the - libs are still compatible, then you *must* make the appropriate - changes under the assumption that they're not. Getting this wrong - is very BAD(TM). - -* Make the final update to the version numbers in GUILE-VERSION and - README. (There are many places in README that need updating!). See - HACKING for more information on how the version numbers are to be - chosen. - -* Reformat the names in THANKS. - -* Do a `cvs -z3 update -Pd' of the whole tree, to look for any stray - uncommitted or accidental changes. - -* Commit your changes. - -* Make one last test distribution. - -Punting checklist: - -* Add "Guile X.Y.Z released." entry to the top-level ChangeLog, and commit it. - -* Tag the entire source tree with a tag of the form "release_X-Y-Z", - i.e for release 1.6.0, use release_1-6-0 - -* Do a 'make dist'. - -* Put the distribution up for FTP somewhere, and send mail to - ftp-upload@gnu.org, asking them to put it on prep. - -* Send an announcement message to gnu-announce@gnu.org. Put a brief - summary of the changes in this release first, then "Obtaining - Guile", "Thanks", "About This Distribution," and "Nightly - Snapshots." If I remember correctly, the moderator will delay it - until the distribution appears on ftp.gnu.org. The announcement - text should be mostly taken from Guile's README file. - -* Notify freshmeat.net, although they're probably watching anyway. - (They got the 1.3 release just fine.) I have no idea if - www.bowerbird.com.au will be something anyone refers to, but Guile - does have an entry there. From fc4fc6f6f0ed6e9e88ea02032ca0525191f0d6c1 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:46:41 +0000 Subject: [PATCH 57/81] * autogen.sh: make absolutely sure we can't have stale files from old versions lying around the libltdl dir since libtoolize doesn't. Also hack libltdl's configure.in to require autoconf 2.5 so the main tree and libltdl can't get out of sync again. --- autogen.sh | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/autogen.sh b/autogen.sh index 9b867aacc..163fb9359 100755 --- a/autogen.sh +++ b/autogen.sh @@ -1,5 +1,7 @@ #!/bin/sh +set -e + [ -f GUILE-VERSION ] || { echo "autogen.sh: run this command only at the top of a Guile source tree." exit 1 @@ -7,16 +9,32 @@ ./guile-aclocal.sh -libtoolize --copy --force --automake --ltdl +###################################################################### +### Libtool setup. + +# Get a clean version. +rm -rf libltdl +libtoolize --force --copy --automake --ltdl + +# Make sure we use a ./configure.in compatible autoconf in ./libltdl/ +mv libltdl/configure.in libltdl/configure.tmp +echo 'AC_PREREQ(2.50)' > libltdl/configure.in +cat libltdl/configure.tmp >> libltdl/configure.in +rm libltdl/configure.tmp +###################################################################### + autoheader autoconf automake --add-missing # Make sure that libltdl uses the same autoconf version as the rest. # -( echo "libltdl..."; cd libltdl; autoconf ) +echo "libltdl..." +(cd libltdl && autoconf) +(cd libltdl && automake --gnu --add-missing) -( echo "guile-readline..."; cd guile-readline; ./autogen.sh ) +echo "guile-readline..." +(cd guile-readline && ./autogen.sh) echo "Now run configure and make." echo "You must pass the \`--enable-maintainer-mode' option to configure." From 1cadfbc0dd09fbcda4ae7e112c5df31e8c99a7d4 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:49:44 +0000 Subject: [PATCH 58/81] * GUILE-VERSION: move all but guile-readline library versioning information here. guile-readline is still standalone. Bump CURRENT interfaces to 15 to allow some headroom for 1.6 release at Thi-Thien's request. * configure.in: AC_SUBST the centralized shared lib versioning variables from ./GUILE-VERSION. (LIBQTHREADS_INTERFACE_CURRENT): new AC_SUBST. (LIBQTHREADS_INTERFACE_REVISION): new AC_SUBST. (LIBQTHREADS_INTERFACE_AGE): new AC_SUBST. (LIBQTHREADS_INTERFACE): new AC_SUBST. (LIBGUILE_INTERFACE_CURRENT): new AC_SUBST. (LIBGUILE_INTERFACE_REVISION): new AC_SUBST. (LIBGUILE_INTERFACE_AGE): new AC_SUBST. (LIBGUILE_INTERFACE): new AC_SUBST. (LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT): new AC_SUBST. (LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION): new AC_SUBST. (LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE): new AC_SUBST. (LIBGUILE_SRFI_SRFI_4_INTERFACE): new AC_SUBST. (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT): new AC_SUBST. (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION): new AC_SUBST. (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE): new AC_SUBST. (LIBGUILE_SRFI_SRFI_13_14_INTERFACE): new AC_SUBST. --- GUILE-VERSION | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 5aa7e6c66..f687039de 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -12,17 +12,32 @@ GUILE_VERSION=${GUILE_VERSION}.${GUILE_MICRO_VERSION} VERSION=${GUILE_VERSION} PACKAGE=guile +# All of the shared lib versioning info. Right now, for this to work +# properly, you'll also need to add AC_SUBST calls to the right place +# in configure.in, add the right -version-info statement to your +# Makefile.am The only library not handled here is +# guile-readline/libguile-readline. It is handled in +# ./guile-readline/LIBGUILEREADLINE-VERSION. + # See libtool info pages for more information on how and when to # change these. -# libguile.so versioning info -LIBGUILE_INTERFACE_CURRENT=10 +LIBQTHREADS_INTERFACE_CURRENT=15 +LIBQTHREADS_INTERFACE_REVISION=0 +LIBQTHREADS_INTERFACE_AGE=0 +LIBQTHREADS_INTERFACE="${LIBQTHREADS_INTERFACE_CURRENT}:${LIBQTHREADS_INTERFACE_REVISION}:${LIBQTHREADS_INTERFACE_AGE}" + +LIBGUILE_INTERFACE_CURRENT=15 LIBGUILE_INTERFACE_REVISION=0 LIBGUILE_INTERFACE_AGE=0 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" -# libguileqthreads.so versioning info -LIBGUILEQTHREADS_INTERFACE_CURRENT=1 -LIBGUILEQTHREADS_INTERFACE_REVISION=0 -LIBGUILEQTHREADS_INTERFACE_AGE=0 -LIBGUILEQTHREADS_INTERFACE="${LIBGUILEQTHREADS_INTERFACE_CURRENT}:${LIBGUILEQTHREADS_INTERFACE_REVISION}:${LIBGUILEQTHREADS_INTERFACE_AGE}" +LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT=1 +LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION=0 +LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE=0 +LIBGUILE_SRFI_SRFI_4_INTERFACE="${LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE}" + +LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT=1 +LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION=0 +LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE=0 +LIBGUILE_SRFI_SRFI_13_14_INTERFACE="${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE}" From c5a4c0e6f2c46336f4e54067f2b0f919710043f2 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:56:04 +0000 Subject: [PATCH 59/81] * LIBGUILEREADLINE-VERSION: new file containing shared lib versioning information. --- guile-readline/LIBGUILEREADLINE-VERSION | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 guile-readline/LIBGUILEREADLINE-VERSION diff --git a/guile-readline/LIBGUILEREADLINE-VERSION b/guile-readline/LIBGUILEREADLINE-VERSION new file mode 100644 index 000000000..ecab91095 --- /dev/null +++ b/guile-readline/LIBGUILEREADLINE-VERSION @@ -0,0 +1,13 @@ +# -*-shell-script-*- + +# This file contains the shared library versioning information. Right +# now, for this to work properly, you'll also need to add AC_SUBST +# calls to the right place in configure.in, add the right +# -version-info statement to your Makefile.am, and add a call to +# source this file from configure.in. Later we may automate more of +# this. + +LIBGUILEREADLINE_INTERFACE_CURRENT=10 +LIBGUILEREADLINE_INTERFACE_REVISION=0 +LIBGUILEREADLINE_INTERFACE_AGE=0 +LIBGUILEREADLINE_INTERFACE="${LIBGUILEREADLINE_INTERFACE_CURRENT}:${LIBGUILEREADLINE_INTERFACE_REVISION}:${LIBGUILEREADLINE_INTERFACE_AGE}" From 0bb2ba7ac178c22461d0011367233d4738cdc111 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:58:48 +0000 Subject: [PATCH 60/81] * Makefile.am (libguilereadline_la_LDFLAGS): use @LIBGUILEREADLINE_INTERFACE@ for version information. --- guile-readline/Makefile.am | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index 054cffbb7..bf5b0ba75 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -33,8 +33,10 @@ GUILE_SNARF = ../libguile/guile-snarf lib_LTLIBRARIES = libguilereadline.la libguilereadline_la_SOURCES = readline.c -libguilereadline_la_LDFLAGS = -export-dynamic -no-undefined libguilereadline_la_LIBADD = ../libguile/libguile.la +libguilereadline_la_LDFLAGS = -version-info @LIBGUILEREADLINE_INTERFACE@ \ + -export-dynamic -no-undefined + BUILT_SOURCES = readline.x From cbab485527c78cb815ff4577e9faeb1c4bee550f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:59:01 +0000 Subject: [PATCH 61/81] * configure.in: source ./LIBGUILEREADLINE-VERSION for version info and then AC_SUBST the resulting variables: LIBGUILEREADLINE_INTERFACE_CURRENT, LIBGUILEREADLINE_INTERFACE_REVISION, LIBGUILEREADLINE_INTERFACE_AGE, and LIBGUILEREADLINE_INTERFACE. --- guile-readline/configure.in | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/guile-readline/configure.in b/guile-readline/configure.in index eb7b1b02b..b10d1a4b9 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -119,5 +119,11 @@ fi AC_CHECK_FUNCS(strdup) +. ./LIBGUILEREADLINE-VERSION +AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT) +AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION) +AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE) +AC_SUBST(LIBGUILEREADLINE_INTERFACE) + AC_CONFIG_FILES(Makefile) AC_OUTPUT From 7084b49f2d6fcfd1643967340b7cf31e0d036f81 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:59:34 +0000 Subject: [PATCH 62/81] * Makefile.am (CLEANFILES): add autoconf-macros.texi. --- doc/ref/Makefile.am | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index d9da61d85..3cb3888dc 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -57,3 +57,5 @@ guile_toc.html: guile.texi $(guile_TEXINFOS) $(TEXI2HTML) -split_chapter guile.texi endif + +CLEANFILES = autoconf-macros.texi From 4313811588d64eff0cd6ad2f5c8523882a353df4 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:59:42 +0000 Subject: [PATCH 63/81] * .cvsignore: add autoconf-macros.texi. --- doc/ref/.cvsignore | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/doc/ref/.cvsignore b/doc/ref/.cvsignore index 9a38defe2..dd408965c 100644 --- a/doc/ref/.cvsignore +++ b/doc/ref/.cvsignore @@ -1,25 +1,26 @@ -Makefile -Makefile.in -stamp-vti -stamp-vti.1 -*.log -*.dvi *.aux -*.toc *.cp +*.cps +*.dvi *.fn -*.vr -*.tp -*.ky -*.pg +*.fns *.ge +*.html +*.info* +*.ky +*.log +*.pg +*.ps *.rn *.rns -*.cps -*.fns +*.toc +*.tp *.tps +*.vr *.vrs -*.ps -*.info* -*.html +Makefile +Makefile.in +autoconf-macros.texi +stamp-vti +stamp-vti.1 version.texi From 8794fdcad068c6a0d32ac4d98ef1d8e6d58b0ae6 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 04:59:49 +0000 Subject: [PATCH 64/81] *** empty log message *** --- doc/ref/ChangeLog | 6 ++++++ guile-readline/ChangeLog | 15 +++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index caaeb6a51..f07a7ee11 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2002-02-24 Rob Browning + + * .cvsignore: add autoconf-macros.texi. + + * Makefile.am (CLEANFILES): add autoconf-macros.texi. + 2002-02-19 Marius Vollmer * scheme-memory.texi (Memory Blocks): New section. diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 8bf80cc90..a34865503 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,18 @@ +2002-02-24 Rob Browning + + * configure.in: source ./LIBGUILEREADLINE-VERSION for version info + and then AC_SUBST the resulting variables: + LIBGUILEREADLINE_INTERFACE_CURRENT, + LIBGUILEREADLINE_INTERFACE_REVISION, + LIBGUILEREADLINE_INTERFACE_AGE, and + LIBGUILEREADLINE_INTERFACE. + + * Makefile.am (libguilereadline_la_LDFLAGS): use + @LIBGUILEREADLINE_INTERFACE@ for version information. + + * LIBGUILEREADLINE-VERSION: new file containing shared lib + versioning information. + 2002-02-12 Thien-Thi Nguyen * Makefile.am (AUTOMAKE_OPTIONS): Replace "gnu" with "foreign". From 9970456903058733bbcab5464a1eb447a6293f94 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 05:48:52 +0000 Subject: [PATCH 65/81] * psyntax.pp: updated to reflect new syncase.scm. --- ice-9/psyntax.pp | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ice-9/psyntax.pp b/ice-9/psyntax.pp index 48e1f7156..e3701c740 100644 --- a/ice-9/psyntax.pp +++ b/ice-9/psyntax.pp @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list116 (lambda (vars323) (let lvl324 ((vars325 vars323) (ls326 (quote ())) (w327 (quote (())))) (cond ((pair? vars325) (lvl324 (cdr vars325) (cons (wrap95 (car vars325) w327) ls326) w327)) ((id?67 vars325) (cons (wrap95 vars325 w327) ls326)) ((null? vars325) ls326) ((syntax-object?53 vars325) (lvl324 (syntax-object-expression54 vars325) ls326 (join-wraps86 w327 (syntax-object-wrap55 vars325)))) ((annotation?42 vars325) (lvl324 (annotation-expression vars325) ls326 w327)) (else (cons vars325 ls326)))))) (gen-var115 (lambda (id328) (let ((id329 (if (syntax-object?53 id328) (syntax-object-expression54 id328) id328))) (if (annotation?42 id329) (gensym (symbol->string (annotation-expression id329))) (gensym (symbol->string id329)))))) (strip114 (lambda (x330 w331) (if (memq (quote top) (wrap-marks70 w331)) (if (or (annotation?42 x330) (and (pair? x330) (annotation?42 (car x330)))) (strip-annotation113 x330 (quote #f)) x330) (let f332 ((x333 x330)) (cond ((syntax-object?53 x333) (strip114 (syntax-object-expression54 x333) (syntax-object-wrap55 x333))) ((pair? x333) (let ((a334 (f332 (car x333))) (d335 (f332 (cdr x333)))) (if (and (eq? a334 (car x333)) (eq? d335 (cdr x333))) x333 (cons a334 d335)))) ((vector? x333) (let ((old336 (vector->list x333))) (let ((new337 (map f332 old336))) (if (andmap eq? old336 new337) x333 (list->vector new337))))) (else x333)))))) (strip-annotation113 (lambda (x338 parent339) (cond ((pair? x338) (let ((new340 (cons (quote #f) (quote #f)))) (begin (when parent339 (set-annotation-stripped! parent339 new340)) (set-car! new340 (strip-annotation113 (car x338) (quote #f))) (set-cdr! new340 (strip-annotation113 (cdr x338) (quote #f))) new340))) ((annotation?42 x338) (or (annotation-stripped x338) (strip-annotation113 (annotation-expression x338) x338))) ((vector? x338) (let ((new341 (make-vector (vector-length x338)))) (begin (when parent339 (set-annotation-stripped! parent339 new341)) (let loop342 ((i343 (- (vector-length x338) (quote 1)))) (unless (fx<41 i343 (quote 0)) (vector-set! new341 i343 (strip-annotation113 (vector-ref x338 i343) (quote #f))) (loop342 (fx-39 i343 (quote 1))))) new341))) (else x338)))) (ellipsis?112 (lambda (x344) (and (nonsymbol-id?66 x344) (free-id=?90 x344 (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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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"))))))))) (chi-void111 (lambda () (list (quote void)))) (eval-local-transformer110 (lambda (expanded345) (let ((p346 (local-eval-hook44 expanded345))) (if (procedure? p346) p346 (syntax-error p346 (quote "nonprocedure transfomer")))))) (chi-local-syntax109 (lambda (rec?347 e348 r349 w350 s351 k352) ((lambda (tmp353) ((lambda (tmp354) (if tmp354 (apply (lambda (_355 id356 val357 e1358 e2359) (let ((ids360 id356)) (if (not (valid-bound-ids?92 ids360)) (syntax-error e348 (quote "duplicate bound keyword in")) (let ((labels362 (gen-labels73 ids360))) (let ((new-w363 (make-binding-wrap84 ids360 labels362 w350))) (k352 (cons e1358 e2359) (extend-env61 labels362 (let ((w365 (if rec?347 new-w363 w350)) (trans-r366 (macros-only-env63 r349))) (map (lambda (x367) (cons (quote macro) (eval-local-transformer110 (chi103 x367 trans-r366 w365)))) val357)) r349) new-w363 s351)))))) tmp354) ((lambda (_369) (syntax-error (source-wrap96 e348 w350 s351))) tmp353))) (syntax-dispatch tmp353 (quote (any #(each (any any)) any . each-any))))) e348))) (chi-lambda-clause108 (lambda (e370 c371 r372 w373 k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (id377 e1378 e2379) (let ((ids380 id377)) (if (not (valid-bound-ids?92 ids380)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels382 (gen-labels73 ids380)) (new-vars383 (map gen-var115 ids380))) (k374 new-vars383 (chi-body107 (cons e1378 e2379) e370 (extend-var-env62 labels382 new-vars383 r372) (make-binding-wrap84 ids380 labels382 w373))))))) tmp376) ((lambda (tmp385) (if tmp385 (apply (lambda (ids386 e1387 e2388) (let ((old-ids389 (lambda-var-list116 ids386))) (if (not (valid-bound-ids?92 old-ids389)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels390 (gen-labels73 old-ids389)) (new-vars391 (map gen-var115 old-ids389))) (k374 (let f392 ((ls1393 (cdr new-vars391)) (ls2394 (car new-vars391))) (if (null? ls1393) ls2394 (f392 (cdr ls1393) (cons (car ls1393) ls2394)))) (chi-body107 (cons e1387 e2388) e370 (extend-var-env62 labels390 new-vars391 r372) (make-binding-wrap84 old-ids389 labels390 w373))))))) tmp385) ((lambda (_396) (syntax-error e370)) tmp375))) (syntax-dispatch tmp375 (quote (any any . each-any)))))) (syntax-dispatch tmp375 (quote (each-any any . each-any))))) c371))) (chi-body107 (lambda (body397 outer-form398 r399 w400) (let ((r401 (cons (quote ("placeholder" placeholder)) r399))) (let ((ribcage402 (make-ribcage74 (quote ()) (quote ()) (quote ())))) (let ((w403 (make-wrap69 (wrap-marks70 w400) (cons ribcage402 (wrap-subst71 w400))))) (let parse404 ((body405 (map (lambda (x411) (cons r401 (wrap95 x411 w403))) body397)) (ids406 (quote ())) (labels407 (quote ())) (vars408 (quote ())) (vals409 (quote ())) (bindings410 (quote ()))) (if (null? body405) (syntax-error outer-form398 (quote "no expressions in body")) (let ((e412 (cdar body405)) (er413 (caar body405))) (call-with-values (lambda () (syntax-type101 e412 er413 (quote (())) (quote #f) ribcage402)) (lambda (type414 value415 e416 w417 s418) (let ((t419 type414)) (if (memv t419 (quote (define-form))) (let ((id420 (wrap95 value415 w417)) (label421 (gen-label72))) (let ((var422 (gen-var115 id420))) (begin (extend-ribcage!83 ribcage402 id420 label421) (parse404 (cdr body405) (cons id420 ids406) (cons label421 labels407) (cons var422 vars408) (cons (cons er413 (wrap95 e416 w417)) vals409) (cons (cons (quote lexical) var422) bindings410))))) (if (memv t419 (quote (define-syntax-form))) (let ((id423 (wrap95 value415 w417)) (label424 (gen-label72))) (begin (extend-ribcage!83 ribcage402 id423 label424) (parse404 (cdr body405) (cons id423 ids406) (cons label424 labels407) vars408 vals409 (cons (cons (quote macro) (cons er413 (wrap95 e416 w417))) bindings410)))) (if (memv t419 (quote (begin-form))) ((lambda (tmp425) ((lambda (tmp426) (if tmp426 (apply (lambda (_427 e1428) (parse404 (let f429 ((forms430 e1428)) (if (null? forms430) (cdr body405) (cons (cons er413 (wrap95 (car forms430) w417)) (f429 (cdr forms430))))) ids406 labels407 vars408 vals409 bindings410)) tmp426) (syntax-error tmp425))) (syntax-dispatch tmp425 (quote (any . each-any))))) e416) (if (memv t419 (quote (local-syntax-form))) (chi-local-syntax109 value415 e416 er413 w417 s418 (lambda (forms432 er433 w434 s435) (parse404 (let f436 ((forms437 forms432)) (if (null? forms437) (cdr body405) (cons (cons er433 (wrap95 (car forms437) w434)) (f436 (cdr forms437))))) ids406 labels407 vars408 vals409 bindings410))) (if (null? ids406) (build-sequence48 (quote #f) (map (lambda (x438) (chi103 (cdr x438) (car x438) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))) (begin (if (not (valid-bound-ids?92 ids406)) (syntax-error outer-form398 (quote "invalid or duplicate identifier in definition"))) (let loop439 ((bs440 bindings410) (er-cache441 (quote #f)) (r-cache442 (quote #f))) (if (not (null? bs440)) (let ((b443 (car bs440))) (if (eq? (car b443) (quote macro)) (let ((er444 (cadr b443))) (let ((r-cache445 (if (eq? er444 er-cache441) r-cache442 (macros-only-env63 er444)))) (begin (set-cdr! b443 (eval-local-transformer110 (chi103 (cddr b443) r-cache445 (quote (()))))) (loop439 (cdr bs440) er444 r-cache445)))) (loop439 (cdr bs440) er-cache441 r-cache442))))) (set-cdr! r401 (extend-env61 labels407 bindings410 (cdr r401))) (build-letrec51 (quote #f) vars408 (map (lambda (x446) (chi103 (cdr x446) (car x446) (quote (())))) vals409) (build-sequence48 (quote #f) (map (lambda (x447) (chi103 (cdr x447) (car x447) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))))))))))))))))))))) (chi-macro106 (lambda (p448 e449 r450 w451 rib452) (letrec ((rebuild-macro-output453 (lambda (x454 m455) (cond ((pair? x454) (cons (rebuild-macro-output453 (car x454) m455) (rebuild-macro-output453 (cdr x454) m455))) ((syntax-object?53 x454) (let ((w456 (syntax-object-wrap55 x454))) (let ((ms457 (wrap-marks70 w456)) (s458 (wrap-subst71 w456))) (make-syntax-object52 (syntax-object-expression54 x454) (if (and (pair? ms457) (eq? (car ms457) (quote #f))) (make-wrap69 (cdr ms457) (if rib452 (cons rib452 (cdr s458)) (cdr s458))) (make-wrap69 (cons m455 ms457) (if rib452 (cons rib452 (cons (quote shift) s458)) (cons (quote shift) s458)))))))) ((vector? x454) (let ((n459 (vector-length x454))) (let ((v460 (make-vector n459))) (let doloop461 ((i462 (quote 0))) (if (fx=40 i462 n459) v460 (begin (vector-set! v460 i462 (rebuild-macro-output453 (vector-ref x454 i462) m455)) (doloop461 (fx+38 i462 (quote 1))))))))) ((symbol? x454) (syntax-error x454 (quote "encountered raw symbol in macro output"))) (else x454))))) (rebuild-macro-output453 (p448 (wrap95 e449 (anti-mark82 w451))) (string (quote #\m)))))) (chi-application105 (lambda (x463 e464 r465 w466 s467) ((lambda (tmp468) ((lambda (tmp469) (if tmp469 (apply (lambda (e0470 e1471) (cons x463 (map (lambda (e472) (chi103 e472 r465 w466)) e1471))) tmp469) (syntax-error tmp468))) (syntax-dispatch tmp468 (quote (any . each-any))))) e464))) (chi-expr104 (lambda (type474 value475 e476 r477 w478 s479) (let ((t480 type474)) (if (memv t480 (quote (lexical))) value475 (if (memv t480 (quote (core))) (value475 e476 r477 w478 s479) (if (memv t480 (quote (lexical-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (global-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (constant))) (list (quote quote) (strip114 (source-wrap96 e476 w478 s479) (quote (())))) (if (memv t480 (quote (global))) value475 (if (memv t480 (quote (call))) (chi-application105 (chi103 (car e476) r477 w478) e476 r477 w478 s479) (if (memv t480 (quote (begin-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 e1484 e2485) (chi-sequence97 (cons e1484 e2485) r477 w478 s479)) tmp482) (syntax-error tmp481))) (syntax-dispatch tmp481 (quote (any any . each-any))))) e476) (if (memv t480 (quote (local-syntax-form))) (chi-local-syntax109 value475 e476 r477 w478 s479 chi-sequence97) (if (memv t480 (quote (eval-when-form))) ((lambda (tmp487) ((lambda (tmp488) (if tmp488 (apply (lambda (_489 x490 e1491 e2492) (let ((when-list493 (chi-when-list100 e476 x490 w478))) (if (memq (quote eval) when-list493) (chi-sequence97 (cons e1491 e2492) r477 w478 s479) (chi-void111)))) tmp488) (syntax-error tmp487))) (syntax-dispatch tmp487 (quote (any each-any any . each-any))))) e476) (if (memv t480 (quote (define-form define-syntax-form))) (syntax-error (wrap95 value475 w478) (quote "invalid context for definition of")) (if (memv t480 (quote (syntax))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to pattern variable outside syntax form")) (if (memv t480 (quote (displaced-lexical))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap96 e476 w478 s479)))))))))))))))))) (chi103 (lambda (e496 r497 w498) (call-with-values (lambda () (syntax-type101 e496 r497 w498 (quote #f) (quote #f))) (lambda (type499 value500 e501 w502 s503) (chi-expr104 type499 value500 e501 r497 w502 s503))))) (chi-top102 (lambda (e504 r505 w506 m507 esew508) (call-with-values (lambda () (syntax-type101 e504 r505 w506 (quote #f) (quote #f))) (lambda (type515 value516 e517 w518 s519) (let ((t520 type515)) (if (memv t520 (quote (begin-form))) ((lambda (tmp521) ((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void111)) tmp522) ((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527) (chi-top-sequence98 (cons e1526 e2527) r505 w518 s519 m507 esew508)) tmp524) (syntax-error tmp521))) (syntax-dispatch tmp521 (quote (any any . each-any)))))) (syntax-dispatch tmp521 (quote (any))))) e517) (if (memv t520 (quote (local-syntax-form))) (chi-local-syntax109 value516 e517 r505 w518 s519 (lambda (body529 r530 w531 s532) (chi-top-sequence98 body529 r530 w531 s532 m507 esew508))) (if (memv t520 (quote (eval-when-form))) ((lambda (tmp533) ((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let ((when-list539 (chi-when-list100 e517 x536 w518)) (body540 (cons e1537 e2538))) (cond ((eq? m507 (quote e)) (if (memq (quote eval) when-list539) (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval))) (chi-void111))) ((memq (quote load) when-list539) (if (or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (chi-top-sequence98 body540 r505 w518 s519 (quote c&e) (quote (compile load))) (if (memq m507 (quote (c c&e))) (chi-top-sequence98 body540 r505 w518 s519 (quote c) (quote (load))) (chi-void111)))) ((or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (top-level-eval-hook43 (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval)))) (chi-void111)) (else (chi-void111))))) tmp534) (syntax-error tmp533))) (syntax-dispatch tmp533 (quote (any each-any any . each-any))))) e517) (if (memv t520 (quote (define-syntax-form))) (let ((n543 (id-var-name89 value516 w518)) (r544 (macros-only-env63 r505))) (let ((t545 m507)) (if (memv t545 (quote (c))) (if (memq (quote compile) esew508) (let ((e546 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e546) (if (memq (quote load) esew508) e546 (chi-void111)))) (if (memq (quote load) esew508) (chi-install-global99 n543 (chi103 e517 r544 w518)) (chi-void111))) (if (memv t545 (quote (c&e))) (let ((e547 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e547) e547)) (begin (if (memq (quote eval) esew508) (top-level-eval-hook43 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (chi-void111)))))) (if (memv t520 (quote (define-form))) (let ((n548 (id-var-name89 value516 w518))) (let ((t549 (binding-type59 (lookup64 n548 r505)))) (if (memv t549 (quote (global))) (let ((x550 (list (quote define) n548 (chi103 e517 r505 w518)))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x550)) x550)) (if (memv t549 (quote (displaced-lexical))) (syntax-error (wrap95 value516 w518) (quote "identifier out of context")) (syntax-error (wrap95 value516 w518) (quote "cannot define keyword at top level")))))) (let ((x551 (chi-expr104 type515 value516 e517 r505 w518 s519))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x551)) x551)))))))))))) (syntax-type101 (lambda (e552 r553 w554 s555 rib556) (cond ((symbol? e552) (let ((n557 (id-var-name89 e552 w554))) (let ((b558 (lookup64 n557 r553))) (let ((type559 (binding-type59 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value60 b558) e552 w554 s555) (if (memv t560 (quote (global))) (values type559 n557 e552 w554 s555) (if (memv t560 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b558) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (values type559 (binding-value60 b558) e552 w554 s555))))))))) ((pair? e552) (let ((first561 (car e552))) (if (id?67 first561) (let ((n562 (id-var-name89 first561 w554))) (let ((b563 (lookup64 n562 r553))) (let ((type564 (binding-type59 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (global))) (values (quote global-call) n562 e552 w554 s555) (if (memv t565 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b563) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (if (memv t565 (quote (core))) (values type564 (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (begin))) (values (quote begin-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?67 name569)) tmp567) (quote #f)) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?67 name576) (valid-bound-ids?92 (lambda-var-list116 args577)))) tmp574) (quote #f)) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap95 name581 w554) (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) #((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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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"))))) (wrap95 (cons args582 (cons e1583 e2584)) w554)) (quote (())) s555)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?67 name588)) tmp586) (quote #f)) (apply (lambda (_589 name590) (values (quote define-form) (wrap95 name590 w554) (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) #((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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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")))))) (quote (())) s555)) tmp586) (syntax-error tmp566))) (syntax-dispatch tmp566 (quote (any any)))))) (syntax-dispatch tmp566 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp566 (quote (any any any))))) e552) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?67 name594)) tmp592) (quote #f)) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555)) tmp592) (syntax-error tmp591))) (syntax-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) (quote #f) e552 w554 s555)))))))))))))) (values (quote call) (quote #f) e552 w554 s555)))) ((syntax-object?53 e552) (syntax-type101 (syntax-object-expression54 e552) r553 (join-wraps86 w554 (syntax-object-wrap55 e552)) (quote #f) rib556)) ((annotation?42 e552) (syntax-type101 (annotation-expression e552) r553 w554 (annotation-source e552) rib556)) ((let ((x599 e552)) (or (boolean? x599) (number? x599) (string? x599) (char? x599) (null? x599) (keyword? x599))) (values (quote constant) (quote #f) e552 w554 s555)) (else (values (quote other) (quote #f) e552 w554 s555))))) (chi-when-list100 (lambda (e600 when-list601 w602) (let f603 ((when-list604 when-list601) (situations605 (quote ()))) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (cond ((free-id=?90 x606 (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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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")))))) (quote compile)) ((free-id=?90 x606 (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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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")))))) (quote load)) ((free-id=?90 x606 (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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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")))))) (quote eval)) (else (syntax-error (wrap95 x606 w602) (quote "invalid eval-when situation"))))) situations605)))))) (chi-install-global99 (lambda (name607 e608) (list (quote install-global-transformer) (list (quote quote) name607) e608))) (chi-top-sequence98 (lambda (body609 r610 w611 s612 m613 esew614) (build-sequence48 s612 (let dobody615 ((body616 body609) (r617 r610) (w618 w611) (m619 m613) (esew620 esew614)) (if (null? body616) (quote ()) (let ((first621 (chi-top102 (car body616) r617 w618 m619 esew620))) (cons first621 (dobody615 (cdr body616) r617 w618 m619 esew620)))))))) (chi-sequence97 (lambda (body622 r623 w624 s625) (build-sequence48 s625 (let dobody626 ((body627 body622) (r628 r623) (w629 w624)) (if (null? body627) (quote ()) (let ((first630 (chi103 (car body627) r628 w629))) (cons first630 (dobody626 (cdr body627) r628 w629)))))))) (source-wrap96 (lambda (x631 w632 s633) (wrap95 (if s633 (make-annotation x631 s633 (quote #f)) x631) w632))) (wrap95 (lambda (x634 w635) (cond ((and (null? (wrap-marks70 w635)) (null? (wrap-subst71 w635))) x634) ((syntax-object?53 x634) (make-syntax-object52 (syntax-object-expression54 x634) (join-wraps86 w635 (syntax-object-wrap55 x634)))) ((null? x634) x634) (else (make-syntax-object52 x634 w635))))) (bound-id-member?94 (lambda (x636 list637) (and (not (null? list637)) (or (bound-id=?91 x636 (car list637)) (bound-id-member?94 x636 (cdr list637)))))) (distinct-bound-ids?93 (lambda (ids638) (let distinct?639 ((ids640 ids638)) (or (null? ids640) (and (not (bound-id-member?94 (car ids640) (cdr ids640))) (distinct?639 (cdr ids640))))))) (valid-bound-ids?92 (lambda (ids641) (and (let all-ids?642 ((ids643 ids641)) (or (null? ids643) (and (id?67 (car ids643)) (all-ids?642 (cdr ids643))))) (distinct-bound-ids?93 ids641)))) (bound-id=?91 (lambda (i644 j645) (if (and (syntax-object?53 i644) (syntax-object?53 j645)) (and (eq? (let ((e646 (syntax-object-expression54 i644))) (if (annotation?42 e646) (annotation-expression e646) e646)) (let ((e647 (syntax-object-expression54 j645))) (if (annotation?42 e647) (annotation-expression e647) e647))) (same-marks?88 (wrap-marks70 (syntax-object-wrap55 i644)) (wrap-marks70 (syntax-object-wrap55 j645)))) (eq? (let ((e648 i644)) (if (annotation?42 e648) (annotation-expression e648) e648)) (let ((e649 j645)) (if (annotation?42 e649) (annotation-expression e649) e649)))))) (free-id=?90 (lambda (i650 j651) (and (eq? (let ((x652 i650)) (let ((e653 (if (syntax-object?53 x652) (syntax-object-expression54 x652) x652))) (if (annotation?42 e653) (annotation-expression e653) e653))) (let ((x654 j651)) (let ((e655 (if (syntax-object?53 x654) (syntax-object-expression54 x654) x654))) (if (annotation?42 e655) (annotation-expression e655) e655)))) (eq? (id-var-name89 i650 (quote (()))) (id-var-name89 j651 (quote (()))))))) (id-var-name89 (lambda (id656 w657) (letrec ((search-vector-rib660 (lambda (sym666 subst667 marks668 symnames669 ribcage670) (let ((n671 (vector-length symnames669))) (let f672 ((i673 (quote 0))) (cond ((fx=40 i673 n671) (search658 sym666 (cdr subst667) marks668)) ((and (eq? (vector-ref symnames669 i673) sym666) (same-marks?88 marks668 (vector-ref (ribcage-marks77 ribcage670) i673))) (values (vector-ref (ribcage-labels78 ribcage670) i673) marks668)) (else (f672 (fx+38 i673 (quote 1))))))))) (search-list-rib659 (lambda (sym674 subst675 marks676 symnames677 ribcage678) (let f679 ((symnames680 symnames677) (i681 (quote 0))) (cond ((null? symnames680) (search658 sym674 (cdr subst675) marks676)) ((and (eq? (car symnames680) sym674) (same-marks?88 marks676 (list-ref (ribcage-marks77 ribcage678) i681))) (values (list-ref (ribcage-labels78 ribcage678) i681) marks676)) (else (f679 (cdr symnames680) (fx+38 i681 (quote 1)))))))) (search658 (lambda (sym682 subst683 marks684) (if (null? subst683) (values (quote #f) marks684) (let ((fst685 (car subst683))) (if (eq? fst685 (quote shift)) (search658 sym682 (cdr subst683) (cdr marks684)) (let ((symnames686 (ribcage-symnames76 fst685))) (if (vector? symnames686) (search-vector-rib660 sym682 subst683 marks684 symnames686 fst685) (search-list-rib659 sym682 subst683 marks684 symnames686 fst685))))))))) (cond ((symbol? id656) (or (call-with-values (lambda () (search658 id656 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x688 . ignore687) x688)) id656)) ((syntax-object?53 id656) (let ((id689 (let ((e691 (syntax-object-expression54 id656))) (if (annotation?42 e691) (annotation-expression e691) e691))) (w1690 (syntax-object-wrap55 id656))) (let ((marks692 (join-marks87 (wrap-marks70 w657) (wrap-marks70 w1690)))) (call-with-values (lambda () (search658 id689 (wrap-subst71 w657) marks692)) (lambda (new-id693 marks694) (or new-id693 (call-with-values (lambda () (search658 id689 (wrap-subst71 w1690) marks694)) (lambda (x696 . ignore695) x696)) id689)))))) ((annotation?42 id656) (let ((id697 (let ((e698 id656)) (if (annotation?42 e698) (annotation-expression e698) e698)))) (or (call-with-values (lambda () (search658 id697 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x700 . ignore699) x700)) id697))) (else (error-hook45 (quote id-var-name) (quote "invalid id") id656)))))) (same-marks?88 (lambda (x701 y702) (or (eq? x701 y702) (and (not (null? x701)) (not (null? y702)) (eq? (car x701) (car y702)) (same-marks?88 (cdr x701) (cdr y702)))))) (join-marks87 (lambda (m1703 m2704) (smart-append85 m1703 m2704))) (join-wraps86 (lambda (w1705 w2706) (let ((m1707 (wrap-marks70 w1705)) (s1708 (wrap-subst71 w1705))) (if (null? m1707) (if (null? s1708) w2706 (make-wrap69 (wrap-marks70 w2706) (smart-append85 s1708 (wrap-subst71 w2706)))) (make-wrap69 (smart-append85 m1707 (wrap-marks70 w2706)) (smart-append85 s1708 (wrap-subst71 w2706))))))) (smart-append85 (lambda (m1709 m2710) (if (null? m2710) m1709 (append m1709 m2710)))) (make-binding-wrap84 (lambda (ids711 labels712 w713) (if (null? ids711) w713 (make-wrap69 (wrap-marks70 w713) (cons (let ((labelvec714 (list->vector labels712))) (let ((n715 (vector-length labelvec714))) (let ((symnamevec716 (make-vector n715)) (marksvec717 (make-vector n715))) (begin (let f718 ((ids719 ids711) (i720 (quote 0))) (if (not (null? ids719)) (call-with-values (lambda () (id-sym-name&marks68 (car ids719) w713)) (lambda (symname721 marks722) (begin (vector-set! symnamevec716 i720 symname721) (vector-set! marksvec717 i720 marks722) (f718 (cdr ids719) (fx+38 i720 (quote 1)))))))) (make-ribcage74 symnamevec716 marksvec717 labelvec714))))) (wrap-subst71 w713)))))) (extend-ribcage!83 (lambda (ribcage723 id724 label725) (begin (set-ribcage-symnames!79 ribcage723 (cons (let ((e726 (syntax-object-expression54 id724))) (if (annotation?42 e726) (annotation-expression e726) e726)) (ribcage-symnames76 ribcage723))) (set-ribcage-marks!80 ribcage723 (cons (wrap-marks70 (syntax-object-wrap55 id724)) (ribcage-marks77 ribcage723))) (set-ribcage-labels!81 ribcage723 (cons label725 (ribcage-labels78 ribcage723)))))) (anti-mark82 (lambda (w727) (make-wrap69 (cons (quote #f) (wrap-marks70 w727)) (cons (quote shift) (wrap-subst71 w727))))) (set-ribcage-labels!81 (lambda (x728 update729) (vector-set! x728 (quote 3) update729))) (set-ribcage-marks!80 (lambda (x730 update731) (vector-set! x730 (quote 2) update731))) (set-ribcage-symnames!79 (lambda (x732 update733) (vector-set! x732 (quote 1) update733))) (ribcage-labels78 (lambda (x734) (vector-ref x734 (quote 3)))) (ribcage-marks77 (lambda (x735) (vector-ref x735 (quote 2)))) (ribcage-symnames76 (lambda (x736) (vector-ref x736 (quote 1)))) (ribcage?75 (lambda (x737) (and (vector? x737) (= (vector-length x737) (quote 4)) (eq? (vector-ref x737 (quote 0)) (quote ribcage))))) (make-ribcage74 (lambda (symnames738 marks739 labels740) (vector (quote ribcage) symnames738 marks739 labels740))) (gen-labels73 (lambda (ls741) (if (null? ls741) (quote ()) (cons (gen-label72) (gen-labels73 (cdr ls741)))))) (gen-label72 (lambda () (string (quote #\i)))) (wrap-subst71 cdr) (wrap-marks70 car) (make-wrap69 cons) (id-sym-name&marks68 (lambda (x742 w743) (if (syntax-object?53 x742) (values (let ((e744 (syntax-object-expression54 x742))) (if (annotation?42 e744) (annotation-expression e744) e744)) (join-marks87 (wrap-marks70 w743) (wrap-marks70 (syntax-object-wrap55 x742)))) (values (let ((e745 x742)) (if (annotation?42 e745) (annotation-expression e745) e745)) (wrap-marks70 w743))))) (id?67 (lambda (x746) (cond ((symbol? x746) (quote #t)) ((syntax-object?53 x746) (symbol? (let ((e747 (syntax-object-expression54 x746))) (if (annotation?42 e747) (annotation-expression e747) e747)))) ((annotation?42 x746) (symbol? (annotation-expression x746))) (else (quote #f))))) (nonsymbol-id?66 (lambda (x748) (and (syntax-object?53 x748) (symbol? (let ((e749 (syntax-object-expression54 x748))) (if (annotation?42 e749) (annotation-expression e749) e749)))))) (global-extend65 (lambda (type750 sym751 val752) (put-global-definition-hook46 sym751 (cons type750 val752)))) (lookup64 (lambda (x753 r754) (cond ((assq x753 r754) => cdr) ((symbol? x753) (or (get-global-definition-hook47 x753) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env63 (lambda (r755) (if (null? r755) (quote ()) (let ((a756 (car r755))) (if (eq? (cadr a756) (quote macro)) (cons a756 (macros-only-env63 (cdr r755))) (macros-only-env63 (cdr r755))))))) (extend-var-env62 (lambda (labels757 vars758 r759) (if (null? labels757) r759 (extend-var-env62 (cdr labels757) (cdr vars758) (cons (cons (car labels757) (cons (quote lexical) (car vars758))) r759))))) (extend-env61 (lambda (labels760 bindings761 r762) (if (null? labels760) r762 (extend-env61 (cdr labels760) (cdr bindings761) (cons (cons (car labels760) (car bindings761)) r762))))) (binding-value60 cdr) (binding-type59 car) (source-annotation58 (lambda (x763) (cond ((annotation?42 x763) (annotation-source x763)) ((syntax-object?53 x763) (source-annotation58 (syntax-object-expression54 x763))) (else (quote #f))))) (set-syntax-object-wrap!57 (lambda (x764 update765) (vector-set! x764 (quote 2) update765))) (set-syntax-object-expression!56 (lambda (x766 update767) (vector-set! x766 (quote 1) update767))) (syntax-object-wrap55 (lambda (x768) (vector-ref x768 (quote 2)))) (syntax-object-expression54 (lambda (x769) (vector-ref x769 (quote 1)))) (syntax-object?53 (lambda (x770) (and (vector? x770) (= (vector-length x770) (quote 3)) (eq? (vector-ref x770 (quote 0)) (quote syntax-object))))) (make-syntax-object52 (lambda (expression771 wrap772) (vector (quote syntax-object) expression771 wrap772))) (build-letrec51 (lambda (src773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (list (quote letrec) (map list vars774 val-exps775) body-exp776)))) (build-named-let50 (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let49 (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence48 (lambda (src785 exps786) (if (null? (cdr exps786)) (car exps786) (cons (quote begin) exps786)))) (get-global-definition-hook47 (lambda (symbol787) (getprop symbol787 (quote *sc-expander*)))) (put-global-definition-hook46 (lambda (symbol788 binding789) (putprop symbol788 (quote *sc-expander*) binding789))) (error-hook45 (lambda (who790 why791 what792) (error who790 (quote "~a ~s") why791 what792))) (local-eval-hook44 (lambda (x793) (eval (list noexpand37 x793) (interaction-environment)))) (top-level-eval-hook43 (lambda (x794) (eval (list noexpand37 x794) (interaction-environment)))) (annotation?42 (lambda (x795) (quote #f))) (fx<41 <) (fx=40 =) (fx-39 -) (fx+38 +) (noexpand37 (quote "noexpand"))) (begin (global-extend65 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend65 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend65 (quote core) (quote fluid-let-syntax) (lambda (e796 r797 w798 s799) ((lambda (tmp800) ((lambda (tmp801) (if (if tmp801 (apply (lambda (_802 var803 val804 e1805 e2806) (valid-bound-ids?92 var803)) tmp801) (quote #f)) (apply (lambda (_808 var809 val810 e1811 e2812) (let ((names813 (map (lambda (x814) (id-var-name89 x814 w798)) var809))) (begin (for-each (lambda (id816 n817) (let ((t818 (binding-type59 (lookup64 n817 r797)))) (if (memv t818 (quote (displaced-lexical))) (syntax-error (source-wrap96 id816 w798 s799) (quote "identifier out of context"))))) var809 names813) (chi-body107 (cons e1811 e2812) (source-wrap96 e796 w798 s799) (extend-env61 names813 (let ((trans-r821 (macros-only-env63 r797))) (map (lambda (x822) (cons (quote macro) (eval-local-transformer110 (chi103 x822 trans-r821 w798)))) val810)) r797) w798)))) tmp801) ((lambda (_824) (syntax-error (source-wrap96 e796 w798 s799))) tmp800))) (syntax-dispatch tmp800 (quote (any #(each (any any)) any . each-any))))) e796))) (global-extend65 (quote core) (quote quote) (lambda (e825 r826 w827 s828) ((lambda (tmp829) ((lambda (tmp830) (if tmp830 (apply (lambda (_831 e832) (list (quote quote) (strip114 e832 w827))) tmp830) ((lambda (_833) (syntax-error (source-wrap96 e825 w827 s828))) tmp829))) (syntax-dispatch tmp829 (quote (any any))))) e825))) (global-extend65 (quote core) (quote syntax) (letrec ((regen841 (lambda (x842) (let ((t843 (car x842))) (if (memv t843 (quote (ref))) (cadr x842) (if (memv t843 (quote (primitive))) (cadr x842) (if (memv t843 (quote (quote))) (list (quote quote) (cadr x842)) (if (memv t843 (quote (lambda))) (list (quote lambda) (cadr x842) (regen841 (caddr x842))) (if (memv t843 (quote (map))) (let ((ls844 (map regen841 (cdr x842)))) (cons (if (fx=40 (length ls844) (quote 2)) (quote map) (quote map)) ls844)) (cons (car x842) (map regen841 (cdr x842))))))))))) (gen-vector840 (lambda (x845) (cond ((eq? (car x845) (quote list)) (cons (quote vector) (cdr x845))) ((eq? (car x845) (quote quote)) (list (quote quote) (list->vector (cadr x845)))) (else (list (quote list->vector) x845))))) (gen-append839 (lambda (x846 y847) (if (equal? y847 (quote (quote ()))) x846 (list (quote append) x846 y847)))) (gen-cons838 (lambda (x848 y849) (let ((t850 (car y849))) (if (memv t850 (quote (quote))) (if (eq? (car x848) (quote quote)) (list (quote quote) (cons (cadr x848) (cadr y849))) (if (eq? (cadr y849) (quote ())) (list (quote list) x848) (list (quote cons) x848 y849))) (if (memv t850 (quote (list))) (cons (quote list) (cons x848 (cdr y849))) (list (quote cons) x848 y849)))))) (gen-map837 (lambda (e851 map-env852) (let ((formals853 (map cdr map-env852)) (actuals854 (map (lambda (x855) (list (quote ref) (car x855))) map-env852))) (cond ((eq? (car e851) (quote ref)) (car actuals854)) ((andmap (lambda (x856) (and (eq? (car x856) (quote ref)) (memq (cadr x856) formals853))) (cdr e851)) (cons (quote map) (cons (list (quote primitive) (car e851)) (map (let ((r857 (map cons formals853 actuals854))) (lambda (x858) (cdr (assq (cadr x858) r857)))) (cdr e851))))) (else (cons (quote map) (cons (list (quote lambda) formals853 e851) actuals854))))))) (gen-mappend836 (lambda (e859 map-env860) (list (quote apply) (quote (primitive append)) (gen-map837 e859 map-env860)))) (gen-ref835 (lambda (src861 var862 level863 maps864) (if (fx=40 level863 (quote 0)) (values var862 maps864) (if (null? maps864) (syntax-error src861 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref835 src861 var862 (fx-39 level863 (quote 1)) (cdr maps864))) (lambda (outer-var865 outer-maps866) (let ((b867 (assq outer-var865 (car maps864)))) (if b867 (values (cdr b867) maps864) (let ((inner-var868 (gen-var115 (quote tmp)))) (values inner-var868 (cons (cons (cons outer-var865 inner-var868) (car maps864)) outer-maps866))))))))))) (gen-syntax834 (lambda (src869 e870 r871 maps872 ellipsis?873) (if (id?67 e870) (let ((label874 (id-var-name89 e870 (quote (()))))) (let ((b875 (lookup64 label874 r871))) (if (eq? (binding-type59 b875) (quote syntax)) (call-with-values (lambda () (let ((var.lev876 (binding-value60 b875))) (gen-ref835 src869 (car var.lev876) (cdr var.lev876) maps872))) (lambda (var877 maps878) (values (list (quote ref) var877) maps878))) (if (ellipsis?873 e870) (syntax-error src869 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e870) maps872))))) ((lambda (tmp879) ((lambda (tmp880) (if (if tmp880 (apply (lambda (dots881 e882) (ellipsis?873 dots881)) tmp880) (quote #f)) (apply (lambda (dots883 e884) (gen-syntax834 src869 e884 r871 maps872 (lambda (x885) (quote #f)))) tmp880) ((lambda (tmp886) (if (if tmp886 (apply (lambda (x887 dots888 y889) (ellipsis?873 dots888)) tmp886) (quote #f)) (apply (lambda (x890 dots891 y892) (let f893 ((y894 y892) (k895 (lambda (maps896) (call-with-values (lambda () (gen-syntax834 src869 x890 r871 (cons (quote ()) maps896) ellipsis?873)) (lambda (x897 maps898) (if (null? (car maps898)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-map837 x897 (car maps898)) (cdr maps898)))))))) ((lambda (tmp899) ((lambda (tmp900) (if (if tmp900 (apply (lambda (dots901 y902) (ellipsis?873 dots901)) tmp900) (quote #f)) (apply (lambda (dots903 y904) (f893 y904 (lambda (maps905) (call-with-values (lambda () (k895 (cons (quote ()) maps905))) (lambda (x906 maps907) (if (null? (car maps907)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-mappend836 x906 (car maps907)) (cdr maps907)))))))) tmp900) ((lambda (_908) (call-with-values (lambda () (gen-syntax834 src869 y894 r871 maps872 ellipsis?873)) (lambda (y909 maps910) (call-with-values (lambda () (k895 maps910)) (lambda (x911 maps912) (values (gen-append839 x911 y909) maps912)))))) tmp899))) (syntax-dispatch tmp899 (quote (any . any))))) y894))) tmp886) ((lambda (tmp913) (if tmp913 (apply (lambda (x914 y915) (call-with-values (lambda () (gen-syntax834 src869 x914 r871 maps872 ellipsis?873)) (lambda (x916 maps917) (call-with-values (lambda () (gen-syntax834 src869 y915 r871 maps917 ellipsis?873)) (lambda (y918 maps919) (values (gen-cons838 x916 y918) maps919)))))) tmp913) ((lambda (tmp920) (if tmp920 (apply (lambda (e1921 e2922) (call-with-values (lambda () (gen-syntax834 src869 (cons e1921 e2922) r871 maps872 ellipsis?873)) (lambda (e924 maps925) (values (gen-vector840 e924) maps925)))) tmp920) ((lambda (_926) (values (list (quote quote) e870) maps872)) tmp879))) (syntax-dispatch tmp879 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp879 (quote (any . any)))))) (syntax-dispatch tmp879 (quote (any any . any)))))) (syntax-dispatch tmp879 (quote (any any))))) e870))))) (lambda (e927 r928 w929 s930) (let ((e931 (source-wrap96 e927 w929 s930))) ((lambda (tmp932) ((lambda (tmp933) (if tmp933 (apply (lambda (_934 x935) (call-with-values (lambda () (gen-syntax834 e931 x935 r928 (quote ()) ellipsis?112)) (lambda (e936 maps937) (regen841 e936)))) tmp933) ((lambda (_938) (syntax-error e931)) tmp932))) (syntax-dispatch tmp932 (quote (any any))))) e931))))) (global-extend65 (quote core) (quote lambda) (lambda (e939 r940 w941 s942) ((lambda (tmp943) ((lambda (tmp944) (if tmp944 (apply (lambda (_945 c946) (chi-lambda-clause108 (source-wrap96 e939 w941 s942) c946 r940 w941 (lambda (vars947 body948) (list (quote lambda) vars947 body948)))) tmp944) (syntax-error tmp943))) (syntax-dispatch tmp943 (quote (any . any))))) e939))) (global-extend65 (quote core) (quote let) (letrec ((chi-let949 (lambda (e950 r951 w952 s953 constructor954 ids955 vals956 exps957) (if (not (valid-bound-ids?92 ids955)) (syntax-error e950 (quote "duplicate bound variable in")) (let ((labels958 (gen-labels73 ids955)) (new-vars959 (map gen-var115 ids955))) (let ((nw960 (make-binding-wrap84 ids955 labels958 w952)) (nr961 (extend-var-env62 labels958 new-vars959 r951))) (constructor954 s953 new-vars959 (map (lambda (x962) (chi103 x962 r951 w952)) vals956) (chi-body107 exps957 (source-wrap96 e950 nw960 s953) nr961 nw960)))))))) (lambda (e963 r964 w965 s966) ((lambda (tmp967) ((lambda (tmp968) (if tmp968 (apply (lambda (_969 id970 val971 e1972 e2973) (chi-let949 e963 r964 w965 s966 build-let49 id970 val971 (cons e1972 e2973))) tmp968) ((lambda (tmp977) (if (if tmp977 (apply (lambda (_978 f979 id980 val981 e1982 e2983) (id?67 f979)) tmp977) (quote #f)) (apply (lambda (_984 f985 id986 val987 e1988 e2989) (chi-let949 e963 r964 w965 s966 build-named-let50 (cons f985 id986) val987 (cons e1988 e2989))) tmp977) ((lambda (_993) (syntax-error (source-wrap96 e963 w965 s966))) tmp967))) (syntax-dispatch tmp967 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp967 (quote (any #(each (any any)) any . each-any))))) e963)))) (global-extend65 (quote core) (quote letrec) (lambda (e994 r995 w996 s997) ((lambda (tmp998) ((lambda (tmp999) (if tmp999 (apply (lambda (_1000 id1001 val1002 e11003 e21004) (let ((ids1005 id1001)) (if (not (valid-bound-ids?92 ids1005)) (syntax-error e994 (quote "duplicate bound variable in")) (let ((labels1007 (gen-labels73 ids1005)) (new-vars1008 (map gen-var115 ids1005))) (let ((w1009 (make-binding-wrap84 ids1005 labels1007 w996)) (r1010 (extend-var-env62 labels1007 new-vars1008 r995))) (build-letrec51 s997 new-vars1008 (map (lambda (x1011) (chi103 x1011 r1010 w1009)) val1002) (chi-body107 (cons e11003 e21004) (source-wrap96 e994 w1009 s997) r1010 w1009))))))) tmp999) ((lambda (_1014) (syntax-error (source-wrap96 e994 w996 s997))) tmp998))) (syntax-dispatch tmp998 (quote (any #(each (any any)) any . each-any))))) e994))) (global-extend65 (quote core) (quote set!) (lambda (e1015 r1016 w1017 s1018) ((lambda (tmp1019) ((lambda (tmp1020) (if (if tmp1020 (apply (lambda (_1021 id1022 val1023) (id?67 id1022)) tmp1020) (quote #f)) (apply (lambda (_1024 id1025 val1026) (let ((val1027 (chi103 val1026 r1016 w1017)) (n1028 (id-var-name89 id1025 w1017))) (let ((b1029 (lookup64 n1028 r1016))) (let ((t1030 (binding-type59 b1029))) (if (memv t1030 (quote (lexical))) (list (quote set!) (binding-value60 b1029) val1027) (if (memv t1030 (quote (global))) (list (quote set!) n1028 val1027) (if (memv t1030 (quote (displaced-lexical))) (syntax-error (wrap95 id1025 w1017) (quote "identifier out of context")) (syntax-error (source-wrap96 e1015 w1017 s1018))))))))) tmp1020) ((lambda (tmp1031) (if tmp1031 (apply (lambda (_1032 getter1033 arg1034 val1035) (cons (chi103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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"))))) getter1033) r1016 w1017) (map (lambda (e1036) (chi103 e1036 r1016 w1017)) (append arg1034 (list val1035))))) tmp1031) ((lambda (_1038) (syntax-error (source-wrap96 e1015 w1017 s1018))) tmp1019))) (syntax-dispatch tmp1019 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp1019 (quote (any any any))))) e1015))) (global-extend65 (quote begin) (quote begin) (quote ())) (global-extend65 (quote define) (quote define) (quote ())) (global-extend65 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend65 (quote eval-when) (quote eval-when) (quote ())) (global-extend65 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1042 (lambda (x1043 keys1044 clauses1045 r1046) (if (null? clauses1045) (list (quote syntax-error) x1043) ((lambda (tmp1047) ((lambda (tmp1048) (if tmp1048 (apply (lambda (pat1049 exp1050) (if (and (id?67 pat1049) (andmap (lambda (x1051) (not (free-id=?90 pat1049 x1051))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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"))))) keys1044))) (let ((labels1052 (list (gen-label72))) (var1053 (gen-var115 pat1049))) (list (list (quote lambda) (list var1053) (chi103 exp1050 (extend-env61 labels1052 (list (cons (quote syntax) (cons var1053 (quote 0)))) r1046) (make-binding-wrap84 (list pat1049) labels1052 (quote (()))))) x1043)) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1049 (quote #t) exp1050))) tmp1048) ((lambda (tmp1054) (if tmp1054 (apply (lambda (pat1055 fender1056 exp1057) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1055 fender1056 exp1057)) tmp1054) ((lambda (_1058) (syntax-error (car clauses1045) (quote "invalid syntax-case clause"))) tmp1047))) (syntax-dispatch tmp1047 (quote (any any any)))))) (syntax-dispatch tmp1047 (quote (any any))))) (car clauses1045))))) (gen-clause1041 (lambda (x1059 keys1060 clauses1061 r1062 pat1063 fender1064 exp1065) (call-with-values (lambda () (convert-pattern1039 pat1063 keys1060)) (lambda (p1066 pvars1067) (cond ((not (distinct-bound-ids?93 (map car pvars1067))) (syntax-error pat1063 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1068) (not (ellipsis?112 (car x1068)))) pvars1067)) (syntax-error pat1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1069 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list y1069) (let ((y1070 y1069)) (list (quote if) ((lambda (tmp1071) ((lambda (tmp1072) (if tmp1072 (apply (lambda () y1070) tmp1072) ((lambda (_1073) (list (quote if) y1070 (build-dispatch-call1040 pvars1067 fender1064 y1070 r1062) (list (quote quote) (quote #f)))) tmp1071))) (syntax-dispatch tmp1071 (quote #(atom #t))))) fender1064) (build-dispatch-call1040 pvars1067 exp1065 y1070 r1062) (gen-syntax-case1042 x1059 keys1060 clauses1061 r1062)))) (if (eq? p1066 (quote any)) (list (quote list) x1059) (list (quote syntax-dispatch) x1059 (list (quote quote) p1066))))))))))) (build-dispatch-call1040 (lambda (pvars1074 exp1075 y1076 r1077) (let ((ids1078 (map car pvars1074)) (levels1079 (map cdr pvars1074))) (let ((labels1080 (gen-labels73 ids1078)) (new-vars1081 (map gen-var115 ids1078))) (list (quote apply) (list (quote lambda) new-vars1081 (chi103 exp1075 (extend-env61 labels1080 (map (lambda (var1082 level1083) (cons (quote syntax) (cons var1082 level1083))) new-vars1081 (map cdr pvars1074)) r1077) (make-binding-wrap84 ids1078 labels1080 (quote (()))))) y1076))))) (convert-pattern1039 (lambda (pattern1084 keys1085) (let cvt1086 ((p1087 pattern1084) (n1088 (quote 0)) (ids1089 (quote ()))) (if (id?67 p1087) (if (bound-id-member?94 p1087 keys1085) (values (vector (quote free-id) p1087) ids1089) (values (quote any) (cons (cons p1087 n1088) ids1089))) ((lambda (tmp1090) ((lambda (tmp1091) (if (if tmp1091 (apply (lambda (x1092 dots1093) (ellipsis?112 dots1093)) tmp1091) (quote #f)) (apply (lambda (x1094 dots1095) (call-with-values (lambda () (cvt1086 x1094 (fx+38 n1088 (quote 1)) ids1089)) (lambda (p1096 ids1097) (values (if (eq? p1096 (quote any)) (quote each-any) (vector (quote each) p1096)) ids1097)))) tmp1091) ((lambda (tmp1098) (if tmp1098 (apply (lambda (x1099 y1100) (call-with-values (lambda () (cvt1086 y1100 n1088 ids1089)) (lambda (y1101 ids1102) (call-with-values (lambda () (cvt1086 x1099 n1088 ids1102)) (lambda (x1103 ids1104) (values (cons x1103 y1101) ids1104)))))) tmp1098) ((lambda (tmp1105) (if tmp1105 (apply (lambda () (values (quote ()) ids1089)) tmp1105) ((lambda (tmp1106) (if tmp1106 (apply (lambda (x1107) (call-with-values (lambda () (cvt1086 x1107 n1088 ids1089)) (lambda (p1109 ids1110) (values (vector (quote vector) p1109) ids1110)))) tmp1106) ((lambda (x1111) (values (vector (quote atom) (strip114 p1087 (quote (())))) ids1089)) tmp1090))) (syntax-dispatch tmp1090 (quote #(vector each-any)))))) (syntax-dispatch tmp1090 (quote ()))))) (syntax-dispatch tmp1090 (quote (any . any)))))) (syntax-dispatch tmp1090 (quote (any any))))) p1087)))))) (lambda (e1112 r1113 w1114 s1115) (let ((e1116 (source-wrap96 e1112 w1114 s1115))) ((lambda (tmp1117) ((lambda (tmp1118) (if tmp1118 (apply (lambda (_1119 val1120 key1121 m1122) (if (andmap (lambda (x1123) (and (id?67 x1123) (not (ellipsis?112 x1123)))) key1121) (let ((x1125 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list x1125) (gen-syntax-case1042 x1125 key1121 m1122 r1113)) (chi103 val1120 r1113 (quote (()))))) (syntax-error e1116 (quote "invalid literals list in")))) tmp1118) (syntax-error tmp1117))) (syntax-dispatch tmp1117 (quote (any any each-any . each-any))))) e1116))))) (set! sc-expand (let ((m1128 (quote e)) (esew1129 (quote (eval)))) (lambda (x1130) (if (and (pair? x1130) (equal? (car x1130) noexpand37)) (cadr x1130) (chi-top102 x1130 (quote ()) (quote ((top))) m1128 esew1129))))) (set! sc-expand3 (let ((m1131 (quote e)) (esew1132 (quote (eval)))) (lambda (x1134 . rest1133) (if (and (pair? x1134) (equal? (car x1134) noexpand37)) (cadr x1134) (chi-top102 x1134 (quote ()) (quote ((top))) (if (null? rest1133) m1131 (car rest1133)) (if (or (null? rest1133) (null? (cdr rest1133))) esew1132 (cadr rest1133))))))) (set! identifier? (lambda (x1135) (nonsymbol-id?66 x1135))) (set! datum->syntax-object (lambda (id1136 datum1137) (make-syntax-object52 datum1137 (syntax-object-wrap55 id1136)))) (set! syntax-object->datum (lambda (x1138) (strip114 x1138 (quote (()))))) (set! generate-temporaries (lambda (ls1139) (begin (let ((x1140 ls1139)) (if (not (list? x1140)) (error-hook45 (quote generate-temporaries) (quote "invalid argument") x1140))) (map (lambda (x1141) (wrap95 (gensym) (quote ((top))))) ls1139)))) (set! free-identifier=? (lambda (x1142 y1143) (begin (let ((x1144 x1142)) (if (not (nonsymbol-id?66 x1144)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1144))) (let ((x1145 y1143)) (if (not (nonsymbol-id?66 x1145)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1145))) (free-id=?90 x1142 y1143)))) (set! bound-identifier=? (lambda (x1146 y1147) (begin (let ((x1148 x1146)) (if (not (nonsymbol-id?66 x1148)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1148))) (let ((x1149 y1147)) (if (not (nonsymbol-id?66 x1149)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1149))) (bound-id=?91 x1146 y1147)))) (set! syntax-error (lambda (object1151 . messages1150) (begin (for-each (lambda (x1152) (let ((x1153 x1152)) (if (not (string? x1153)) (error-hook45 (quote syntax-error) (quote "invalid argument") x1153)))) messages1150) (let ((message1154 (if (null? messages1150) (quote "invalid syntax") (apply string-append messages1150)))) (error-hook45 (quote #f) message1154 (strip114 object1151 (quote (())))))))) (set! install-global-transformer (lambda (sym1155 v1156) (begin (let ((x1157 sym1155)) (if (not (symbol? x1157)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1157))) (let ((x1158 v1156)) (if (not (procedure? x1158)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1158))) (global-extend65 (quote macro) sym1155 v1156)))) (letrec ((match1163 (lambda (e1164 p1165 w1166 r1167) (cond ((not r1167) (quote #f)) ((eq? p1165 (quote any)) (cons (wrap95 e1164 w1166) r1167)) ((syntax-object?53 e1164) (match*1162 (let ((e1168 (syntax-object-expression54 e1164))) (if (annotation?42 e1168) (annotation-expression e1168) e1168)) p1165 (join-wraps86 w1166 (syntax-object-wrap55 e1164)) r1167)) (else (match*1162 (let ((e1169 e1164)) (if (annotation?42 e1169) (annotation-expression e1169) e1169)) p1165 w1166 r1167))))) (match*1162 (lambda (e1170 p1171 w1172 r1173) (cond ((null? p1171) (and (null? e1170) r1173)) ((pair? p1171) (and (pair? e1170) (match1163 (car e1170) (car p1171) w1172 (match1163 (cdr e1170) (cdr p1171) w1172 r1173)))) ((eq? p1171 (quote each-any)) (let ((l1174 (match-each-any1160 e1170 w1172))) (and l1174 (cons l1174 r1173)))) (else (let ((t1175 (vector-ref p1171 (quote 0)))) (if (memv t1175 (quote (each))) (if (null? e1170) (match-empty1161 (vector-ref p1171 (quote 1)) r1173) (let ((l1176 (match-each1159 e1170 (vector-ref p1171 (quote 1)) w1172))) (and l1176 (let collect1177 ((l1178 l1176)) (if (null? (car l1178)) r1173 (cons (map car l1178) (collect1177 (map cdr l1178)))))))) (if (memv t1175 (quote (free-id))) (and (id?67 e1170) (free-id=?90 (wrap95 e1170 w1172) (vector-ref p1171 (quote 1))) r1173) (if (memv t1175 (quote (atom))) (and (equal? (vector-ref p1171 (quote 1)) (strip114 e1170 w1172)) r1173) (if (memv t1175 (quote (vector))) (and (vector? e1170) (match1163 (vector->list e1170) (vector-ref p1171 (quote 1)) w1172 r1173))))))))))) (match-empty1161 (lambda (p1179 r1180) (cond ((null? p1179) r1180) ((eq? p1179 (quote any)) (cons (quote ()) r1180)) ((pair? p1179) (match-empty1161 (car p1179) (match-empty1161 (cdr p1179) r1180))) ((eq? p1179 (quote each-any)) (cons (quote ()) r1180)) (else (let ((t1181 (vector-ref p1179 (quote 0)))) (if (memv t1181 (quote (each))) (match-empty1161 (vector-ref p1179 (quote 1)) r1180) (if (memv t1181 (quote (free-id atom))) r1180 (if (memv t1181 (quote (vector))) (match-empty1161 (vector-ref p1179 (quote 1)) r1180))))))))) (match-each-any1160 (lambda (e1182 w1183) (cond ((annotation?42 e1182) (match-each-any1160 (annotation-expression e1182) w1183)) ((pair? e1182) (let ((l1184 (match-each-any1160 (cdr e1182) w1183))) (and l1184 (cons (wrap95 (car e1182) w1183) l1184)))) ((null? e1182) (quote ())) ((syntax-object?53 e1182) (match-each-any1160 (syntax-object-expression54 e1182) (join-wraps86 w1183 (syntax-object-wrap55 e1182)))) (else (quote #f))))) (match-each1159 (lambda (e1185 p1186 w1187) (cond ((annotation?42 e1185) (match-each1159 (annotation-expression e1185) p1186 w1187)) ((pair? e1185) (let ((first1188 (match1163 (car e1185) p1186 w1187 (quote ())))) (and first1188 (let ((rest1189 (match-each1159 (cdr e1185) p1186 w1187))) (and rest1189 (cons first1188 rest1189)))))) ((null? e1185) (quote ())) ((syntax-object?53 e1185) (match-each1159 (syntax-object-expression54 e1185) p1186 (join-wraps86 w1187 (syntax-object-wrap55 e1185)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1190 p1191) (cond ((eq? p1191 (quote any)) (list e1190)) ((syntax-object?53 e1190) (match*1162 (let ((e1192 (syntax-object-expression54 e1190))) (if (annotation?42 e1192) (annotation-expression e1192) e1192)) p1191 (syntax-object-wrap55 e1190) (quote ()))) (else (match*1162 (let ((e1193 e1190)) (if (annotation?42 e1193) (annotation-expression e1193) e1193)) p1191 (quote (())) (quote ()))))))))) -(install-global-transformer (quote with-syntax) (lambda (x1194) ((lambda (tmp1195) ((lambda (tmp1196) (if tmp1196 (apply (lambda (_1197 e11198 e21199) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11198 e21199))) tmp1196) ((lambda (tmp1201) (if tmp1201 (apply (lambda (_1202 out1203 in1204 e11205 e21206) (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"))))) in1204 (quote ()) (list out1203 (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"))))) (cons e11205 e21206))))) tmp1201) ((lambda (tmp1208) (if tmp1208 (apply (lambda (_1209 out1210 in1211 e11212 e21213) (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"))))) (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"))))) in1211) (quote ()) (list out1210 (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"))))) (cons e11212 e21213))))) tmp1208) (syntax-error tmp1195))) (syntax-dispatch tmp1195 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1195 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1195 (quote (any () any . each-any))))) x1194))) -(install-global-transformer (quote syntax-rules) (lambda (x1217) ((lambda (tmp1218) ((lambda (tmp1219) (if tmp1219 (apply (lambda (_1220 k1221 keyword1222 pattern1223 template1224) (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"))))) (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")))))) (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"))))) (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"))))) (cons k1221 (map (lambda (tmp1227 tmp1226) (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"))))) tmp1226) (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"))))) tmp1227))) template1224 pattern1223)))))) tmp1219) (syntax-error tmp1218))) (syntax-dispatch tmp1218 (quote (any each-any . #(each ((any . any) any))))))) x1217))) -(install-global-transformer (quote let*) (lambda (x1228) ((lambda (tmp1229) ((lambda (tmp1230) (if (if tmp1230 (apply (lambda (let*1231 x1232 v1233 e11234 e21235) (andmap identifier? x1232)) tmp1230) (quote #f)) (apply (lambda (let*1237 x1238 v1239 e11240 e21241) (let f1242 ((bindings1243 (map list x1238 v1239))) (if (null? bindings1243) (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"))))) (cons (quote ()) (cons e11240 e21241))) ((lambda (tmp1247) ((lambda (tmp1248) (if tmp1248 (apply (lambda (body1249 binding1250) (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"))))) (list binding1250) body1249)) tmp1248) (syntax-error tmp1247))) (syntax-dispatch tmp1247 (quote (any any))))) (list (f1242 (cdr bindings1243)) (car bindings1243)))))) tmp1230) (syntax-error tmp1229))) (syntax-dispatch tmp1229 (quote (any #(each (any any)) any . each-any))))) x1228))) -(install-global-transformer (quote do) (lambda (orig-x1251) ((lambda (tmp1252) ((lambda (tmp1253) (if tmp1253 (apply (lambda (_1254 var1255 init1256 step1257 e01258 e11259 c1260) ((lambda (tmp1261) ((lambda (tmp1262) (if tmp1262 (apply (lambda (step1263) ((lambda (tmp1264) ((lambda (tmp1265) (if tmp1265 (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"))))) (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"))))) (map list var1255 init1256) (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"))))) (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"))))) e01258) (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"))))) (append c1260 (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"))))) step1263))))))) tmp1265) ((lambda (tmp1270) (if tmp1270 (apply (lambda (e11271 e21272) (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"))))) (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"))))) (map list var1255 init1256) (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"))))) e01258 (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"))))) (cons e11271 e21272)) (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"))))) (append c1260 (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"))))) step1263))))))) tmp1270) (syntax-error tmp1264))) (syntax-dispatch tmp1264 (quote (any . each-any)))))) (syntax-dispatch tmp1264 (quote ())))) e11259)) tmp1262) (syntax-error tmp1261))) (syntax-dispatch tmp1261 (quote each-any)))) (map (lambda (v1279 s1280) ((lambda (tmp1281) ((lambda (tmp1282) (if tmp1282 (apply (lambda () v1279) tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (e1284) e1284) tmp1283) ((lambda (_1285) (syntax-error orig-x1251)) tmp1281))) (syntax-dispatch tmp1281 (quote (any)))))) (syntax-dispatch tmp1281 (quote ())))) s1280)) var1255 step1257))) tmp1253) (syntax-error tmp1252))) (syntax-dispatch tmp1252 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1251))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons1288 (lambda (x1292 y1293) ((lambda (tmp1294) ((lambda (tmp1295) (if tmp1295 (apply (lambda (x1296 y1297) ((lambda (tmp1298) ((lambda (tmp1299) (if tmp1299 (apply (lambda (dy1300) ((lambda (tmp1301) ((lambda (tmp1302) (if tmp1302 (apply (lambda (dx1303) (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"))))) (cons dx1303 dy1300))) tmp1302) ((lambda (_1304) (if (null? dy1300) (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"))))) x1296) (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"))))) x1296 y1297))) tmp1301))) (syntax-dispatch tmp1301 (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"))))) any))))) x1296)) tmp1299) ((lambda (tmp1305) (if tmp1305 (apply (lambda (stuff1306) (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"))))) (cons x1296 stuff1306))) tmp1305) ((lambda (else1307) (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"))))) x1296 y1297)) tmp1298))) (syntax-dispatch tmp1298 (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"))))) . any)))))) (syntax-dispatch tmp1298 (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"))))) any))))) y1297)) tmp1295) (syntax-error tmp1294))) (syntax-dispatch tmp1294 (quote (any any))))) (list x1292 y1293)))) (quasiappend1289 (lambda (x1308 y1309) ((lambda (tmp1310) ((lambda (tmp1311) (if tmp1311 (apply (lambda (x1312 y1313) ((lambda (tmp1314) ((lambda (tmp1315) (if tmp1315 (apply (lambda () x1312) tmp1315) ((lambda (_1316) (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"))))) x1312 y1313)) tmp1314))) (syntax-dispatch tmp1314 (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"))))) ()))))) y1313)) tmp1311) (syntax-error tmp1310))) (syntax-dispatch tmp1310 (quote (any any))))) (list x1308 y1309)))) (quasivector1290 (lambda (x1317) ((lambda (tmp1318) ((lambda (x1319) ((lambda (tmp1320) ((lambda (tmp1321) (if tmp1321 (apply (lambda (x1322) (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"))))) (list->vector x1322))) tmp1321) ((lambda (tmp1324) (if tmp1324 (apply (lambda (x1325) (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"))))) x1325)) tmp1324) ((lambda (_1327) (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"))))) x1319)) tmp1320))) (syntax-dispatch tmp1320 (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"))))) . each-any)))))) (syntax-dispatch tmp1320 (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"))))) each-any))))) x1319)) tmp1318)) x1317))) (quasi1291 (lambda (p1328 lev1329) ((lambda (tmp1330) ((lambda (tmp1331) (if tmp1331 (apply (lambda (p1332) (if (= lev1329 (quote 0)) p1332 (quasicons1288 (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")))) #(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")))))) (quasi1291 (list p1332) (- lev1329 (quote 1)))))) tmp1331) ((lambda (tmp1333) (if tmp1333 (apply (lambda (p1334 q1335) (if (= lev1329 (quote 0)) (quasiappend1289 p1334 (quasi1291 q1335 lev1329)) (quasicons1288 (quasicons1288 (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")))) #(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")))))) (quasi1291 (list p1334) (- lev1329 (quote 1)))) (quasi1291 q1335 lev1329)))) tmp1333) ((lambda (tmp1336) (if tmp1336 (apply (lambda (p1337) (quasicons1288 (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")))) #(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")))))) (quasi1291 (list p1337) (+ lev1329 (quote 1))))) tmp1336) ((lambda (tmp1338) (if tmp1338 (apply (lambda (p1339 q1340) (quasicons1288 (quasi1291 p1339 lev1329) (quasi1291 q1340 lev1329))) tmp1338) ((lambda (tmp1341) (if tmp1341 (apply (lambda (x1342) (quasivector1290 (quasi1291 x1342 lev1329))) tmp1341) ((lambda (p1344) (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"))))) p1344)) tmp1330))) (syntax-dispatch tmp1330 (quote #(vector each-any)))))) (syntax-dispatch tmp1330 (quote (any . any)))))) (syntax-dispatch tmp1330 (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"))))) any)))))) (syntax-dispatch tmp1330 (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"))))) any) . any)))))) (syntax-dispatch tmp1330 (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"))))) any))))) p1328)))) (lambda (x1345) ((lambda (tmp1346) ((lambda (tmp1347) (if tmp1347 (apply (lambda (_1348 e1349) (quasi1291 e1349 (quote 0))) tmp1347) (syntax-error tmp1346))) (syntax-dispatch tmp1346 (quote (any any))))) x1345)))) -(install-global-transformer (quote include) (lambda (x1350) (letrec ((read-file1351 (lambda (fn1352 k1353) (let ((p1354 (open-input-file fn1352))) (let f1355 ((x1356 (read p1354))) (if (eof-object? x1356) (begin (close-input-port p1354) (quote ())) (cons (datum->syntax-object k1353 x1356) (f1355 (read p1354))))))))) ((lambda (tmp1357) ((lambda (tmp1358) (if tmp1358 (apply (lambda (k1359 filename1360) (let ((fn1361 (syntax-object->datum filename1360))) ((lambda (tmp1362) ((lambda (tmp1363) (if tmp1363 (apply (lambda (exp1364) (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"))))) exp1364)) tmp1363) (syntax-error tmp1362))) (syntax-dispatch tmp1362 (quote each-any)))) (read-file1351 fn1361 k1359)))) tmp1358) (syntax-error tmp1357))) (syntax-dispatch tmp1357 (quote (any any))))) x1350)))) -(install-global-transformer (quote unquote) (lambda (x1366) ((lambda (tmp1367) ((lambda (tmp1368) (if tmp1368 (apply (lambda (_1369 e1370) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e1370))) tmp1368) (syntax-error tmp1367))) (syntax-dispatch tmp1367 (quote (any any))))) x1366))) -(install-global-transformer (quote unquote-splicing) (lambda (x1371) ((lambda (tmp1372) ((lambda (tmp1373) (if tmp1373 (apply (lambda (_1374 e1375) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1375))) tmp1373) (syntax-error tmp1372))) (syntax-dispatch tmp1372 (quote (any any))))) x1371))) -(install-global-transformer (quote case) (lambda (x1376) ((lambda (tmp1377) ((lambda (tmp1378) (if tmp1378 (apply (lambda (_1379 e1380 m11381 m21382) ((lambda (tmp1383) ((lambda (body1384) (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"))))) (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"))))) e1380)) body1384)) tmp1383)) (let f1385 ((clause1386 m11381) (clauses1387 m21382)) (if (null? clauses1387) ((lambda (tmp1389) ((lambda (tmp1390) (if tmp1390 (apply (lambda (e11391 e21392) (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"))))) (cons e11391 e21392))) tmp1390) ((lambda (tmp1394) (if tmp1394 (apply (lambda (k1395 e11396 e21397) (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"))))) (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"))))) (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"))))) (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"))))) k1395)) (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"))))) (cons e11396 e21397)))) tmp1394) ((lambda (_1400) (syntax-error x1376)) tmp1389))) (syntax-dispatch tmp1389 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1389 (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"))))) any . each-any))))) clause1386) ((lambda (tmp1401) ((lambda (rest1402) ((lambda (tmp1403) ((lambda (tmp1404) (if tmp1404 (apply (lambda (k1405 e11406 e21407) (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"))))) (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"))))) (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"))))) (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"))))) k1405)) (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"))))) (cons e11406 e21407)) rest1402)) tmp1404) ((lambda (_1410) (syntax-error x1376)) tmp1403))) (syntax-dispatch tmp1403 (quote (each-any any . each-any))))) clause1386)) tmp1401)) (f1385 (car clauses1387) (cdr clauses1387))))))) tmp1378) (syntax-error tmp1377))) (syntax-dispatch tmp1377 (quote (any any any . each-any))))) x1376))) -(install-global-transformer (quote identifier-syntax) (lambda (x1411) ((lambda (tmp1412) ((lambda (tmp1413) (if tmp1413 (apply (lambda (_1414 e1415) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1415)) (list (cons _1414 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1415 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1413) (syntax-error tmp1412))) (syntax-dispatch tmp1412 (quote (any any))))) x1411))) +(letrec ((syntmp-lambda-var-list-116 (lambda (syntmp-vars-323) (let syntmp-lvl-324 ((syntmp-vars-325 syntmp-vars-323) (syntmp-ls-326 (quote ())) (syntmp-w-327 (quote (())))) (cond ((pair? syntmp-vars-325) (syntmp-lvl-324 (cdr syntmp-vars-325) (cons (syntmp-wrap-95 (car syntmp-vars-325) syntmp-w-327) syntmp-ls-326) syntmp-w-327)) ((syntmp-id?-67 syntmp-vars-325) (cons (syntmp-wrap-95 syntmp-vars-325 syntmp-w-327) syntmp-ls-326)) ((null? syntmp-vars-325) syntmp-ls-326) ((syntmp-syntax-object?-53 syntmp-vars-325) (syntmp-lvl-324 (syntmp-syntax-object-expression-54 syntmp-vars-325) syntmp-ls-326 (syntmp-join-wraps-86 syntmp-w-327 (syntmp-syntax-object-wrap-55 syntmp-vars-325)))) ((syntmp-annotation?-42 syntmp-vars-325) (syntmp-lvl-324 (annotation-expression syntmp-vars-325) syntmp-ls-326 syntmp-w-327)) (else (cons syntmp-vars-325 syntmp-ls-326)))))) (syntmp-gen-var-115 (lambda (syntmp-id-328) (let ((syntmp-id-329 (if (syntmp-syntax-object?-53 syntmp-id-328) (syntmp-syntax-object-expression-54 syntmp-id-328) syntmp-id-328))) (if (syntmp-annotation?-42 syntmp-id-329) (gensym (symbol->string (annotation-expression syntmp-id-329))) (gensym (symbol->string syntmp-id-329)))))) (syntmp-strip-114 (lambda (syntmp-x-330 syntmp-w-331) (if (memq (quote top) (syntmp-wrap-marks-70 syntmp-w-331)) (if (or (syntmp-annotation?-42 syntmp-x-330) (and (pair? syntmp-x-330) (syntmp-annotation?-42 (car syntmp-x-330)))) (syntmp-strip-annotation-113 syntmp-x-330 (quote #f)) syntmp-x-330) (let syntmp-f-332 ((syntmp-x-333 syntmp-x-330)) (cond ((syntmp-syntax-object?-53 syntmp-x-333) (syntmp-strip-114 (syntmp-syntax-object-expression-54 syntmp-x-333) (syntmp-syntax-object-wrap-55 syntmp-x-333))) ((pair? syntmp-x-333) (let ((syntmp-a-334 (syntmp-f-332 (car syntmp-x-333))) (syntmp-d-335 (syntmp-f-332 (cdr syntmp-x-333)))) (if (and (eq? syntmp-a-334 (car syntmp-x-333)) (eq? syntmp-d-335 (cdr syntmp-x-333))) syntmp-x-333 (cons syntmp-a-334 syntmp-d-335)))) ((vector? syntmp-x-333) (let ((syntmp-old-336 (vector->list syntmp-x-333))) (let ((syntmp-new-337 (map syntmp-f-332 syntmp-old-336))) (if (andmap eq? syntmp-old-336 syntmp-new-337) syntmp-x-333 (list->vector syntmp-new-337))))) (else syntmp-x-333)))))) (syntmp-strip-annotation-113 (lambda (syntmp-x-338 syntmp-parent-339) (cond ((pair? syntmp-x-338) (let ((syntmp-new-340 (cons (quote #f) (quote #f)))) (begin (when syntmp-parent-339 (set-annotation-stripped! syntmp-parent-339 syntmp-new-340)) (set-car! syntmp-new-340 (syntmp-strip-annotation-113 (car syntmp-x-338) (quote #f))) (set-cdr! syntmp-new-340 (syntmp-strip-annotation-113 (cdr syntmp-x-338) (quote #f))) syntmp-new-340))) ((syntmp-annotation?-42 syntmp-x-338) (or (annotation-stripped syntmp-x-338) (syntmp-strip-annotation-113 (annotation-expression syntmp-x-338) syntmp-x-338))) ((vector? syntmp-x-338) (let ((syntmp-new-341 (make-vector (vector-length syntmp-x-338)))) (begin (when syntmp-parent-339 (set-annotation-stripped! syntmp-parent-339 syntmp-new-341)) (let syntmp-loop-342 ((syntmp-i-343 (- (vector-length syntmp-x-338) (quote 1)))) (unless (syntmp-fx<-41 syntmp-i-343 (quote 0)) (vector-set! syntmp-new-341 syntmp-i-343 (syntmp-strip-annotation-113 (vector-ref syntmp-x-338 syntmp-i-343) (quote #f))) (syntmp-loop-342 (syntmp-fx--39 syntmp-i-343 (quote 1))))) syntmp-new-341))) (else syntmp-x-338)))) (syntmp-ellipsis?-112 (lambda (syntmp-x-344) (and (syntmp-nonsymbol-id?-66 syntmp-x-344) (syntmp-free-id=?-90 syntmp-x-344 (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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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"))))))))) (syntmp-chi-void-111 (lambda () (list (quote void)))) (syntmp-eval-local-transformer-110 (lambda (syntmp-expanded-345) (let ((syntmp-p-346 (syntmp-local-eval-hook-44 syntmp-expanded-345))) (if (procedure? syntmp-p-346) syntmp-p-346 (syntax-error syntmp-p-346 (quote "nonprocedure transfomer")))))) (syntmp-chi-local-syntax-109 (lambda (syntmp-rec?-347 syntmp-e-348 syntmp-r-349 syntmp-w-350 syntmp-s-351 syntmp-k-352) ((lambda (syntmp-tmp-353) ((lambda (syntmp-tmp-354) (if syntmp-tmp-354 (apply (lambda (syntmp-_-355 syntmp-id-356 syntmp-val-357 syntmp-e1-358 syntmp-e2-359) (let ((syntmp-ids-360 syntmp-id-356)) (if (not (syntmp-valid-bound-ids?-92 syntmp-ids-360)) (syntax-error syntmp-e-348 (quote "duplicate bound keyword in")) (let ((syntmp-labels-362 (syntmp-gen-labels-73 syntmp-ids-360))) (let ((syntmp-new-w-363 (syntmp-make-binding-wrap-84 syntmp-ids-360 syntmp-labels-362 syntmp-w-350))) (syntmp-k-352 (cons syntmp-e1-358 syntmp-e2-359) (syntmp-extend-env-61 syntmp-labels-362 (let ((syntmp-w-365 (if syntmp-rec?-347 syntmp-new-w-363 syntmp-w-350)) (syntmp-trans-r-366 (syntmp-macros-only-env-63 syntmp-r-349))) (map (lambda (syntmp-x-367) (cons (quote macro) (syntmp-eval-local-transformer-110 (syntmp-chi-103 syntmp-x-367 syntmp-trans-r-366 syntmp-w-365)))) syntmp-val-357)) syntmp-r-349) syntmp-new-w-363 syntmp-s-351)))))) syntmp-tmp-354) ((lambda (syntmp-_-369) (syntax-error (syntmp-source-wrap-96 syntmp-e-348 syntmp-w-350 syntmp-s-351))) syntmp-tmp-353))) (syntax-dispatch syntmp-tmp-353 (quote (any #(each (any any)) any . each-any))))) syntmp-e-348))) (syntmp-chi-lambda-clause-108 (lambda (syntmp-e-370 syntmp-c-371 syntmp-r-372 syntmp-w-373 syntmp-k-374) ((lambda (syntmp-tmp-375) ((lambda (syntmp-tmp-376) (if syntmp-tmp-376 (apply (lambda (syntmp-id-377 syntmp-e1-378 syntmp-e2-379) (let ((syntmp-ids-380 syntmp-id-377)) (if (not (syntmp-valid-bound-ids?-92 syntmp-ids-380)) (syntax-error syntmp-e-370 (quote "invalid parameter list in")) (let ((syntmp-labels-382 (syntmp-gen-labels-73 syntmp-ids-380)) (syntmp-new-vars-383 (map syntmp-gen-var-115 syntmp-ids-380))) (syntmp-k-374 syntmp-new-vars-383 (syntmp-chi-body-107 (cons syntmp-e1-378 syntmp-e2-379) syntmp-e-370 (syntmp-extend-var-env-62 syntmp-labels-382 syntmp-new-vars-383 syntmp-r-372) (syntmp-make-binding-wrap-84 syntmp-ids-380 syntmp-labels-382 syntmp-w-373))))))) syntmp-tmp-376) ((lambda (syntmp-tmp-385) (if syntmp-tmp-385 (apply (lambda (syntmp-ids-386 syntmp-e1-387 syntmp-e2-388) (let ((syntmp-old-ids-389 (syntmp-lambda-var-list-116 syntmp-ids-386))) (if (not (syntmp-valid-bound-ids?-92 syntmp-old-ids-389)) (syntax-error syntmp-e-370 (quote "invalid parameter list in")) (let ((syntmp-labels-390 (syntmp-gen-labels-73 syntmp-old-ids-389)) (syntmp-new-vars-391 (map syntmp-gen-var-115 syntmp-old-ids-389))) (syntmp-k-374 (let syntmp-f-392 ((syntmp-ls1-393 (cdr syntmp-new-vars-391)) (syntmp-ls2-394 (car syntmp-new-vars-391))) (if (null? syntmp-ls1-393) syntmp-ls2-394 (syntmp-f-392 (cdr syntmp-ls1-393) (cons (car syntmp-ls1-393) syntmp-ls2-394)))) (syntmp-chi-body-107 (cons syntmp-e1-387 syntmp-e2-388) syntmp-e-370 (syntmp-extend-var-env-62 syntmp-labels-390 syntmp-new-vars-391 syntmp-r-372) (syntmp-make-binding-wrap-84 syntmp-old-ids-389 syntmp-labels-390 syntmp-w-373))))))) syntmp-tmp-385) ((lambda (syntmp-_-396) (syntax-error syntmp-e-370)) syntmp-tmp-375))) (syntax-dispatch syntmp-tmp-375 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-375 (quote (each-any any . each-any))))) syntmp-c-371))) (syntmp-chi-body-107 (lambda (syntmp-body-397 syntmp-outer-form-398 syntmp-r-399 syntmp-w-400) (let ((syntmp-r-401 (cons (quote ("placeholder" placeholder)) syntmp-r-399))) (let ((syntmp-ribcage-402 (syntmp-make-ribcage-74 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-403 (syntmp-make-wrap-69 (syntmp-wrap-marks-70 syntmp-w-400) (cons syntmp-ribcage-402 (syntmp-wrap-subst-71 syntmp-w-400))))) (let syntmp-parse-404 ((syntmp-body-405 (map (lambda (syntmp-x-411) (cons syntmp-r-401 (syntmp-wrap-95 syntmp-x-411 syntmp-w-403))) syntmp-body-397)) (syntmp-ids-406 (quote ())) (syntmp-labels-407 (quote ())) (syntmp-vars-408 (quote ())) (syntmp-vals-409 (quote ())) (syntmp-bindings-410 (quote ()))) (if (null? syntmp-body-405) (syntax-error syntmp-outer-form-398 (quote "no expressions in body")) (let ((syntmp-e-412 (cdar syntmp-body-405)) (syntmp-er-413 (caar syntmp-body-405))) (call-with-values (lambda () (syntmp-syntax-type-101 syntmp-e-412 syntmp-er-413 (quote (())) (quote #f) syntmp-ribcage-402)) (lambda (syntmp-type-414 syntmp-value-415 syntmp-e-416 syntmp-w-417 syntmp-s-418) (let ((syntmp-t-419 syntmp-type-414)) (if (memv syntmp-t-419 (quote (define-form))) (let ((syntmp-id-420 (syntmp-wrap-95 syntmp-value-415 syntmp-w-417)) (syntmp-label-421 (syntmp-gen-label-72))) (let ((syntmp-var-422 (syntmp-gen-var-115 syntmp-id-420))) (begin (syntmp-extend-ribcage!-83 syntmp-ribcage-402 syntmp-id-420 syntmp-label-421) (syntmp-parse-404 (cdr syntmp-body-405) (cons syntmp-id-420 syntmp-ids-406) (cons syntmp-label-421 syntmp-labels-407) (cons syntmp-var-422 syntmp-vars-408) (cons (cons syntmp-er-413 (syntmp-wrap-95 syntmp-e-416 syntmp-w-417)) syntmp-vals-409) (cons (cons (quote lexical) syntmp-var-422) syntmp-bindings-410))))) (if (memv syntmp-t-419 (quote (define-syntax-form))) (let ((syntmp-id-423 (syntmp-wrap-95 syntmp-value-415 syntmp-w-417)) (syntmp-label-424 (syntmp-gen-label-72))) (begin (syntmp-extend-ribcage!-83 syntmp-ribcage-402 syntmp-id-423 syntmp-label-424) (syntmp-parse-404 (cdr syntmp-body-405) (cons syntmp-id-423 syntmp-ids-406) (cons syntmp-label-424 syntmp-labels-407) syntmp-vars-408 syntmp-vals-409 (cons (cons (quote macro) (cons syntmp-er-413 (syntmp-wrap-95 syntmp-e-416 syntmp-w-417))) syntmp-bindings-410)))) (if (memv syntmp-t-419 (quote (begin-form))) ((lambda (syntmp-tmp-425) ((lambda (syntmp-tmp-426) (if syntmp-tmp-426 (apply (lambda (syntmp-_-427 syntmp-e1-428) (syntmp-parse-404 (let syntmp-f-429 ((syntmp-forms-430 syntmp-e1-428)) (if (null? syntmp-forms-430) (cdr syntmp-body-405) (cons (cons syntmp-er-413 (syntmp-wrap-95 (car syntmp-forms-430) syntmp-w-417)) (syntmp-f-429 (cdr syntmp-forms-430))))) syntmp-ids-406 syntmp-labels-407 syntmp-vars-408 syntmp-vals-409 syntmp-bindings-410)) syntmp-tmp-426) (syntax-error syntmp-tmp-425))) (syntax-dispatch syntmp-tmp-425 (quote (any . each-any))))) syntmp-e-416) (if (memv syntmp-t-419 (quote (local-syntax-form))) (syntmp-chi-local-syntax-109 syntmp-value-415 syntmp-e-416 syntmp-er-413 syntmp-w-417 syntmp-s-418 (lambda (syntmp-forms-432 syntmp-er-433 syntmp-w-434 syntmp-s-435) (syntmp-parse-404 (let syntmp-f-436 ((syntmp-forms-437 syntmp-forms-432)) (if (null? syntmp-forms-437) (cdr syntmp-body-405) (cons (cons syntmp-er-433 (syntmp-wrap-95 (car syntmp-forms-437) syntmp-w-434)) (syntmp-f-436 (cdr syntmp-forms-437))))) syntmp-ids-406 syntmp-labels-407 syntmp-vars-408 syntmp-vals-409 syntmp-bindings-410))) (if (null? syntmp-ids-406) (syntmp-build-sequence-48 (quote #f) (map (lambda (syntmp-x-438) (syntmp-chi-103 (cdr syntmp-x-438) (car syntmp-x-438) (quote (())))) (cons (cons syntmp-er-413 (syntmp-source-wrap-96 syntmp-e-416 syntmp-w-417 syntmp-s-418)) (cdr syntmp-body-405)))) (begin (if (not (syntmp-valid-bound-ids?-92 syntmp-ids-406)) (syntax-error syntmp-outer-form-398 (quote "invalid or duplicate identifier in definition"))) (let syntmp-loop-439 ((syntmp-bs-440 syntmp-bindings-410) (syntmp-er-cache-441 (quote #f)) (syntmp-r-cache-442 (quote #f))) (if (not (null? syntmp-bs-440)) (let ((syntmp-b-443 (car syntmp-bs-440))) (if (eq? (car syntmp-b-443) (quote macro)) (let ((syntmp-er-444 (cadr syntmp-b-443))) (let ((syntmp-r-cache-445 (if (eq? syntmp-er-444 syntmp-er-cache-441) syntmp-r-cache-442 (syntmp-macros-only-env-63 syntmp-er-444)))) (begin (set-cdr! syntmp-b-443 (syntmp-eval-local-transformer-110 (syntmp-chi-103 (cddr syntmp-b-443) syntmp-r-cache-445 (quote (()))))) (syntmp-loop-439 (cdr syntmp-bs-440) syntmp-er-444 syntmp-r-cache-445)))) (syntmp-loop-439 (cdr syntmp-bs-440) syntmp-er-cache-441 syntmp-r-cache-442))))) (set-cdr! syntmp-r-401 (syntmp-extend-env-61 syntmp-labels-407 syntmp-bindings-410 (cdr syntmp-r-401))) (syntmp-build-letrec-51 (quote #f) syntmp-vars-408 (map (lambda (syntmp-x-446) (syntmp-chi-103 (cdr syntmp-x-446) (car syntmp-x-446) (quote (())))) syntmp-vals-409) (syntmp-build-sequence-48 (quote #f) (map (lambda (syntmp-x-447) (syntmp-chi-103 (cdr syntmp-x-447) (car syntmp-x-447) (quote (())))) (cons (cons syntmp-er-413 (syntmp-source-wrap-96 syntmp-e-416 syntmp-w-417 syntmp-s-418)) (cdr syntmp-body-405)))))))))))))))))))))) (syntmp-chi-macro-106 (lambda (syntmp-p-448 syntmp-e-449 syntmp-r-450 syntmp-w-451 syntmp-rib-452) (letrec ((syntmp-rebuild-macro-output-453 (lambda (syntmp-x-454 syntmp-m-455) (cond ((pair? syntmp-x-454) (cons (syntmp-rebuild-macro-output-453 (car syntmp-x-454) syntmp-m-455) (syntmp-rebuild-macro-output-453 (cdr syntmp-x-454) syntmp-m-455))) ((syntmp-syntax-object?-53 syntmp-x-454) (let ((syntmp-w-456 (syntmp-syntax-object-wrap-55 syntmp-x-454))) (let ((syntmp-ms-457 (syntmp-wrap-marks-70 syntmp-w-456)) (syntmp-s-458 (syntmp-wrap-subst-71 syntmp-w-456))) (syntmp-make-syntax-object-52 (syntmp-syntax-object-expression-54 syntmp-x-454) (if (and (pair? syntmp-ms-457) (eq? (car syntmp-ms-457) (quote #f))) (syntmp-make-wrap-69 (cdr syntmp-ms-457) (if syntmp-rib-452 (cons syntmp-rib-452 (cdr syntmp-s-458)) (cdr syntmp-s-458))) (syntmp-make-wrap-69 (cons syntmp-m-455 syntmp-ms-457) (if syntmp-rib-452 (cons syntmp-rib-452 (cons (quote shift) syntmp-s-458)) (cons (quote shift) syntmp-s-458)))))))) ((vector? syntmp-x-454) (let ((syntmp-n-459 (vector-length syntmp-x-454))) (let ((syntmp-v-460 (make-vector syntmp-n-459))) (let syntmp-doloop-461 ((syntmp-i-462 (quote 0))) (if (syntmp-fx=-40 syntmp-i-462 syntmp-n-459) syntmp-v-460 (begin (vector-set! syntmp-v-460 syntmp-i-462 (syntmp-rebuild-macro-output-453 (vector-ref syntmp-x-454 syntmp-i-462) syntmp-m-455)) (syntmp-doloop-461 (syntmp-fx+-38 syntmp-i-462 (quote 1))))))))) ((symbol? syntmp-x-454) (syntax-error syntmp-x-454 (quote "encountered raw symbol in macro output"))) (else syntmp-x-454))))) (syntmp-rebuild-macro-output-453 (syntmp-p-448 (syntmp-wrap-95 syntmp-e-449 (syntmp-anti-mark-82 syntmp-w-451))) (string (quote #\m)))))) (syntmp-chi-application-105 (lambda (syntmp-x-463 syntmp-e-464 syntmp-r-465 syntmp-w-466 syntmp-s-467) ((lambda (syntmp-tmp-468) ((lambda (syntmp-tmp-469) (if syntmp-tmp-469 (apply (lambda (syntmp-e0-470 syntmp-e1-471) (cons syntmp-x-463 (map (lambda (syntmp-e-472) (syntmp-chi-103 syntmp-e-472 syntmp-r-465 syntmp-w-466)) syntmp-e1-471))) syntmp-tmp-469) (syntax-error syntmp-tmp-468))) (syntax-dispatch syntmp-tmp-468 (quote (any . each-any))))) syntmp-e-464))) (syntmp-chi-expr-104 (lambda (syntmp-type-474 syntmp-value-475 syntmp-e-476 syntmp-r-477 syntmp-w-478 syntmp-s-479) (let ((syntmp-t-480 syntmp-type-474)) (if (memv syntmp-t-480 (quote (lexical))) syntmp-value-475 (if (memv syntmp-t-480 (quote (core))) (syntmp-value-475 syntmp-e-476 syntmp-r-477 syntmp-w-478 syntmp-s-479) (if (memv syntmp-t-480 (quote (lexical-call))) (syntmp-chi-application-105 syntmp-value-475 syntmp-e-476 syntmp-r-477 syntmp-w-478 syntmp-s-479) (if (memv syntmp-t-480 (quote (global-call))) (syntmp-chi-application-105 syntmp-value-475 syntmp-e-476 syntmp-r-477 syntmp-w-478 syntmp-s-479) (if (memv syntmp-t-480 (quote (constant))) (list (quote quote) (syntmp-strip-114 (syntmp-source-wrap-96 syntmp-e-476 syntmp-w-478 syntmp-s-479) (quote (())))) (if (memv syntmp-t-480 (quote (global))) syntmp-value-475 (if (memv syntmp-t-480 (quote (call))) (syntmp-chi-application-105 (syntmp-chi-103 (car syntmp-e-476) syntmp-r-477 syntmp-w-478) syntmp-e-476 syntmp-r-477 syntmp-w-478 syntmp-s-479) (if (memv syntmp-t-480 (quote (begin-form))) ((lambda (syntmp-tmp-481) ((lambda (syntmp-tmp-482) (if syntmp-tmp-482 (apply (lambda (syntmp-_-483 syntmp-e1-484 syntmp-e2-485) (syntmp-chi-sequence-97 (cons syntmp-e1-484 syntmp-e2-485) syntmp-r-477 syntmp-w-478 syntmp-s-479)) syntmp-tmp-482) (syntax-error syntmp-tmp-481))) (syntax-dispatch syntmp-tmp-481 (quote (any any . each-any))))) syntmp-e-476) (if (memv syntmp-t-480 (quote (local-syntax-form))) (syntmp-chi-local-syntax-109 syntmp-value-475 syntmp-e-476 syntmp-r-477 syntmp-w-478 syntmp-s-479 syntmp-chi-sequence-97) (if (memv syntmp-t-480 (quote (eval-when-form))) ((lambda (syntmp-tmp-487) ((lambda (syntmp-tmp-488) (if syntmp-tmp-488 (apply (lambda (syntmp-_-489 syntmp-x-490 syntmp-e1-491 syntmp-e2-492) (let ((syntmp-when-list-493 (syntmp-chi-when-list-100 syntmp-e-476 syntmp-x-490 syntmp-w-478))) (if (memq (quote eval) syntmp-when-list-493) (syntmp-chi-sequence-97 (cons syntmp-e1-491 syntmp-e2-492) syntmp-r-477 syntmp-w-478 syntmp-s-479) (syntmp-chi-void-111)))) syntmp-tmp-488) (syntax-error syntmp-tmp-487))) (syntax-dispatch syntmp-tmp-487 (quote (any each-any any . each-any))))) syntmp-e-476) (if (memv syntmp-t-480 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-95 syntmp-value-475 syntmp-w-478) (quote "invalid context for definition of")) (if (memv syntmp-t-480 (quote (syntax))) (syntax-error (syntmp-source-wrap-96 syntmp-e-476 syntmp-w-478 syntmp-s-479) (quote "reference to pattern variable outside syntax form")) (if (memv syntmp-t-480 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-96 syntmp-e-476 syntmp-w-478 syntmp-s-479) (quote "reference to identifier outside its scope")) (syntax-error (syntmp-source-wrap-96 syntmp-e-476 syntmp-w-478 syntmp-s-479)))))))))))))))))) (syntmp-chi-103 (lambda (syntmp-e-496 syntmp-r-497 syntmp-w-498) (call-with-values (lambda () (syntmp-syntax-type-101 syntmp-e-496 syntmp-r-497 syntmp-w-498 (quote #f) (quote #f))) (lambda (syntmp-type-499 syntmp-value-500 syntmp-e-501 syntmp-w-502 syntmp-s-503) (syntmp-chi-expr-104 syntmp-type-499 syntmp-value-500 syntmp-e-501 syntmp-r-497 syntmp-w-502 syntmp-s-503))))) (syntmp-chi-top-102 (lambda (syntmp-e-504 syntmp-r-505 syntmp-w-506 syntmp-m-507 syntmp-esew-508) (call-with-values (lambda () (syntmp-syntax-type-101 syntmp-e-504 syntmp-r-505 syntmp-w-506 (quote #f) (quote #f))) (lambda (syntmp-type-515 syntmp-value-516 syntmp-e-517 syntmp-w-518 syntmp-s-519) (let ((syntmp-t-520 syntmp-type-515)) (if (memv syntmp-t-520 (quote (begin-form))) ((lambda (syntmp-tmp-521) ((lambda (syntmp-tmp-522) (if syntmp-tmp-522 (apply (lambda (syntmp-_-523) (syntmp-chi-void-111)) syntmp-tmp-522) ((lambda (syntmp-tmp-524) (if syntmp-tmp-524 (apply (lambda (syntmp-_-525 syntmp-e1-526 syntmp-e2-527) (syntmp-chi-top-sequence-98 (cons syntmp-e1-526 syntmp-e2-527) syntmp-r-505 syntmp-w-518 syntmp-s-519 syntmp-m-507 syntmp-esew-508)) syntmp-tmp-524) (syntax-error syntmp-tmp-521))) (syntax-dispatch syntmp-tmp-521 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-521 (quote (any))))) syntmp-e-517) (if (memv syntmp-t-520 (quote (local-syntax-form))) (syntmp-chi-local-syntax-109 syntmp-value-516 syntmp-e-517 syntmp-r-505 syntmp-w-518 syntmp-s-519 (lambda (syntmp-body-529 syntmp-r-530 syntmp-w-531 syntmp-s-532) (syntmp-chi-top-sequence-98 syntmp-body-529 syntmp-r-530 syntmp-w-531 syntmp-s-532 syntmp-m-507 syntmp-esew-508))) (if (memv syntmp-t-520 (quote (eval-when-form))) ((lambda (syntmp-tmp-533) ((lambda (syntmp-tmp-534) (if syntmp-tmp-534 (apply (lambda (syntmp-_-535 syntmp-x-536 syntmp-e1-537 syntmp-e2-538) (let ((syntmp-when-list-539 (syntmp-chi-when-list-100 syntmp-e-517 syntmp-x-536 syntmp-w-518)) (syntmp-body-540 (cons syntmp-e1-537 syntmp-e2-538))) (cond ((eq? syntmp-m-507 (quote e)) (if (memq (quote eval) syntmp-when-list-539) (syntmp-chi-top-sequence-98 syntmp-body-540 syntmp-r-505 syntmp-w-518 syntmp-s-519 (quote e) (quote (eval))) (syntmp-chi-void-111))) ((memq (quote load) syntmp-when-list-539) (if (or (memq (quote compile) syntmp-when-list-539) (and (eq? syntmp-m-507 (quote c&e)) (memq (quote eval) syntmp-when-list-539))) (syntmp-chi-top-sequence-98 syntmp-body-540 syntmp-r-505 syntmp-w-518 syntmp-s-519 (quote c&e) (quote (compile load))) (if (memq syntmp-m-507 (quote (c c&e))) (syntmp-chi-top-sequence-98 syntmp-body-540 syntmp-r-505 syntmp-w-518 syntmp-s-519 (quote c) (quote (load))) (syntmp-chi-void-111)))) ((or (memq (quote compile) syntmp-when-list-539) (and (eq? syntmp-m-507 (quote c&e)) (memq (quote eval) syntmp-when-list-539))) (syntmp-top-level-eval-hook-43 (syntmp-chi-top-sequence-98 syntmp-body-540 syntmp-r-505 syntmp-w-518 syntmp-s-519 (quote e) (quote (eval)))) (syntmp-chi-void-111)) (else (syntmp-chi-void-111))))) syntmp-tmp-534) (syntax-error syntmp-tmp-533))) (syntax-dispatch syntmp-tmp-533 (quote (any each-any any . each-any))))) syntmp-e-517) (if (memv syntmp-t-520 (quote (define-syntax-form))) (let ((syntmp-n-543 (syntmp-id-var-name-89 syntmp-value-516 syntmp-w-518)) (syntmp-r-544 (syntmp-macros-only-env-63 syntmp-r-505))) (let ((syntmp-t-545 syntmp-m-507)) (if (memv syntmp-t-545 (quote (c))) (if (memq (quote compile) syntmp-esew-508) (let ((syntmp-e-546 (syntmp-chi-install-global-99 syntmp-n-543 (syntmp-chi-103 syntmp-e-517 syntmp-r-544 syntmp-w-518)))) (begin (syntmp-top-level-eval-hook-43 syntmp-e-546) (if (memq (quote load) syntmp-esew-508) syntmp-e-546 (syntmp-chi-void-111)))) (if (memq (quote load) syntmp-esew-508) (syntmp-chi-install-global-99 syntmp-n-543 (syntmp-chi-103 syntmp-e-517 syntmp-r-544 syntmp-w-518)) (syntmp-chi-void-111))) (if (memv syntmp-t-545 (quote (c&e))) (let ((syntmp-e-547 (syntmp-chi-install-global-99 syntmp-n-543 (syntmp-chi-103 syntmp-e-517 syntmp-r-544 syntmp-w-518)))) (begin (syntmp-top-level-eval-hook-43 syntmp-e-547) syntmp-e-547)) (begin (if (memq (quote eval) syntmp-esew-508) (syntmp-top-level-eval-hook-43 (syntmp-chi-install-global-99 syntmp-n-543 (syntmp-chi-103 syntmp-e-517 syntmp-r-544 syntmp-w-518)))) (syntmp-chi-void-111)))))) (if (memv syntmp-t-520 (quote (define-form))) (let ((syntmp-n-548 (syntmp-id-var-name-89 syntmp-value-516 syntmp-w-518))) (let ((syntmp-t-549 (syntmp-binding-type-59 (syntmp-lookup-64 syntmp-n-548 syntmp-r-505)))) (if (memv syntmp-t-549 (quote (global))) (let ((syntmp-x-550 (list (quote define) syntmp-n-548 (syntmp-chi-103 syntmp-e-517 syntmp-r-505 syntmp-w-518)))) (begin (if (eq? syntmp-m-507 (quote c&e)) (syntmp-top-level-eval-hook-43 syntmp-x-550)) syntmp-x-550)) (if (memv syntmp-t-549 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-95 syntmp-value-516 syntmp-w-518) (quote "identifier out of context")) (syntax-error (syntmp-wrap-95 syntmp-value-516 syntmp-w-518) (quote "cannot define keyword at top level")))))) (let ((syntmp-x-551 (syntmp-chi-expr-104 syntmp-type-515 syntmp-value-516 syntmp-e-517 syntmp-r-505 syntmp-w-518 syntmp-s-519))) (begin (if (eq? syntmp-m-507 (quote c&e)) (syntmp-top-level-eval-hook-43 syntmp-x-551)) syntmp-x-551)))))))))))) (syntmp-syntax-type-101 (lambda (syntmp-e-552 syntmp-r-553 syntmp-w-554 syntmp-s-555 syntmp-rib-556) (cond ((symbol? syntmp-e-552) (let ((syntmp-n-557 (syntmp-id-var-name-89 syntmp-e-552 syntmp-w-554))) (let ((syntmp-b-558 (syntmp-lookup-64 syntmp-n-557 syntmp-r-553))) (let ((syntmp-type-559 (syntmp-binding-type-59 syntmp-b-558))) (let ((syntmp-t-560 syntmp-type-559)) (if (memv syntmp-t-560 (quote (lexical))) (values syntmp-type-559 (syntmp-binding-value-60 syntmp-b-558) syntmp-e-552 syntmp-w-554 syntmp-s-555) (if (memv syntmp-t-560 (quote (global))) (values syntmp-type-559 syntmp-n-557 syntmp-e-552 syntmp-w-554 syntmp-s-555) (if (memv syntmp-t-560 (quote (macro))) (syntmp-syntax-type-101 (syntmp-chi-macro-106 (syntmp-binding-value-60 syntmp-b-558) syntmp-e-552 syntmp-r-553 syntmp-w-554 syntmp-rib-556) syntmp-r-553 (quote (())) syntmp-s-555 syntmp-rib-556) (values syntmp-type-559 (syntmp-binding-value-60 syntmp-b-558) syntmp-e-552 syntmp-w-554 syntmp-s-555))))))))) ((pair? syntmp-e-552) (let ((syntmp-first-561 (car syntmp-e-552))) (if (syntmp-id?-67 syntmp-first-561) (let ((syntmp-n-562 (syntmp-id-var-name-89 syntmp-first-561 syntmp-w-554))) (let ((syntmp-b-563 (syntmp-lookup-64 syntmp-n-562 syntmp-r-553))) (let ((syntmp-type-564 (syntmp-binding-type-59 syntmp-b-563))) (let ((syntmp-t-565 syntmp-type-564)) (if (memv syntmp-t-565 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-60 syntmp-b-563) syntmp-e-552 syntmp-w-554 syntmp-s-555) (if (memv syntmp-t-565 (quote (global))) (values (quote global-call) syntmp-n-562 syntmp-e-552 syntmp-w-554 syntmp-s-555) (if (memv syntmp-t-565 (quote (macro))) (syntmp-syntax-type-101 (syntmp-chi-macro-106 (syntmp-binding-value-60 syntmp-b-563) syntmp-e-552 syntmp-r-553 syntmp-w-554 syntmp-rib-556) syntmp-r-553 (quote (())) syntmp-s-555 syntmp-rib-556) (if (memv syntmp-t-565 (quote (core))) (values syntmp-type-564 (syntmp-binding-value-60 syntmp-b-563) syntmp-e-552 syntmp-w-554 syntmp-s-555) (if (memv syntmp-t-565 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-60 syntmp-b-563) syntmp-e-552 syntmp-w-554 syntmp-s-555) (if (memv syntmp-t-565 (quote (begin))) (values (quote begin-form) (quote #f) syntmp-e-552 syntmp-w-554 syntmp-s-555) (if (memv syntmp-t-565 (quote (eval-when))) (values (quote eval-when-form) (quote #f) syntmp-e-552 syntmp-w-554 syntmp-s-555) (if (memv syntmp-t-565 (quote (define))) ((lambda (syntmp-tmp-566) ((lambda (syntmp-tmp-567) (if (if syntmp-tmp-567 (apply (lambda (syntmp-_-568 syntmp-name-569 syntmp-val-570) (syntmp-id?-67 syntmp-name-569)) syntmp-tmp-567) (quote #f)) (apply (lambda (syntmp-_-571 syntmp-name-572 syntmp-val-573) (values (quote define-form) syntmp-name-572 syntmp-val-573 syntmp-w-554 syntmp-s-555)) syntmp-tmp-567) ((lambda (syntmp-tmp-574) (if (if syntmp-tmp-574 (apply (lambda (syntmp-_-575 syntmp-name-576 syntmp-args-577 syntmp-e1-578 syntmp-e2-579) (and (syntmp-id?-67 syntmp-name-576) (syntmp-valid-bound-ids?-92 (syntmp-lambda-var-list-116 syntmp-args-577)))) syntmp-tmp-574) (quote #f)) (apply (lambda (syntmp-_-580 syntmp-name-581 syntmp-args-582 syntmp-e1-583 syntmp-e2-584) (values (quote define-form) (syntmp-wrap-95 syntmp-name-581 syntmp-w-554) (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) #((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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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"))))) (syntmp-wrap-95 (cons syntmp-args-582 (cons syntmp-e1-583 syntmp-e2-584)) syntmp-w-554)) (quote (())) syntmp-s-555)) syntmp-tmp-574) ((lambda (syntmp-tmp-586) (if (if syntmp-tmp-586 (apply (lambda (syntmp-_-587 syntmp-name-588) (syntmp-id?-67 syntmp-name-588)) syntmp-tmp-586) (quote #f)) (apply (lambda (syntmp-_-589 syntmp-name-590) (values (quote define-form) (syntmp-wrap-95 syntmp-name-590 syntmp-w-554) (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) #((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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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")))))) (quote (())) syntmp-s-555)) syntmp-tmp-586) (syntax-error syntmp-tmp-566))) (syntax-dispatch syntmp-tmp-566 (quote (any any)))))) (syntax-dispatch syntmp-tmp-566 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-566 (quote (any any any))))) syntmp-e-552) (if (memv syntmp-t-565 (quote (define-syntax))) ((lambda (syntmp-tmp-591) ((lambda (syntmp-tmp-592) (if (if syntmp-tmp-592 (apply (lambda (syntmp-_-593 syntmp-name-594 syntmp-val-595) (syntmp-id?-67 syntmp-name-594)) syntmp-tmp-592) (quote #f)) (apply (lambda (syntmp-_-596 syntmp-name-597 syntmp-val-598) (values (quote define-syntax-form) syntmp-name-597 syntmp-val-598 syntmp-w-554 syntmp-s-555)) syntmp-tmp-592) (syntax-error syntmp-tmp-591))) (syntax-dispatch syntmp-tmp-591 (quote (any any any))))) syntmp-e-552) (values (quote call) (quote #f) syntmp-e-552 syntmp-w-554 syntmp-s-555)))))))))))))) (values (quote call) (quote #f) syntmp-e-552 syntmp-w-554 syntmp-s-555)))) ((syntmp-syntax-object?-53 syntmp-e-552) (syntmp-syntax-type-101 (syntmp-syntax-object-expression-54 syntmp-e-552) syntmp-r-553 (syntmp-join-wraps-86 syntmp-w-554 (syntmp-syntax-object-wrap-55 syntmp-e-552)) (quote #f) syntmp-rib-556)) ((syntmp-annotation?-42 syntmp-e-552) (syntmp-syntax-type-101 (annotation-expression syntmp-e-552) syntmp-r-553 syntmp-w-554 (annotation-source syntmp-e-552) syntmp-rib-556)) ((let ((syntmp-x-599 syntmp-e-552)) (or (boolean? syntmp-x-599) (number? syntmp-x-599) (string? syntmp-x-599) (char? syntmp-x-599) (null? syntmp-x-599) (keyword? syntmp-x-599))) (values (quote constant) (quote #f) syntmp-e-552 syntmp-w-554 syntmp-s-555)) (else (values (quote other) (quote #f) syntmp-e-552 syntmp-w-554 syntmp-s-555))))) (syntmp-chi-when-list-100 (lambda (syntmp-e-600 syntmp-when-list-601 syntmp-w-602) (let syntmp-f-603 ((syntmp-when-list-604 syntmp-when-list-601) (syntmp-situations-605 (quote ()))) (if (null? syntmp-when-list-604) syntmp-situations-605 (syntmp-f-603 (cdr syntmp-when-list-604) (cons (let ((syntmp-x-606 (car syntmp-when-list-604))) (cond ((syntmp-free-id=?-90 syntmp-x-606 (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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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")))))) (quote compile)) ((syntmp-free-id=?-90 syntmp-x-606 (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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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")))))) (quote load)) ((syntmp-free-id=?-90 syntmp-x-606 (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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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")))))) (quote eval)) (else (syntax-error (syntmp-wrap-95 syntmp-x-606 syntmp-w-602) (quote "invalid eval-when situation"))))) syntmp-situations-605)))))) (syntmp-chi-install-global-99 (lambda (syntmp-name-607 syntmp-e-608) (list (quote install-global-transformer) (list (quote quote) syntmp-name-607) syntmp-e-608))) (syntmp-chi-top-sequence-98 (lambda (syntmp-body-609 syntmp-r-610 syntmp-w-611 syntmp-s-612 syntmp-m-613 syntmp-esew-614) (syntmp-build-sequence-48 syntmp-s-612 (let syntmp-dobody-615 ((syntmp-body-616 syntmp-body-609) (syntmp-r-617 syntmp-r-610) (syntmp-w-618 syntmp-w-611) (syntmp-m-619 syntmp-m-613) (syntmp-esew-620 syntmp-esew-614)) (if (null? syntmp-body-616) (quote ()) (let ((syntmp-first-621 (syntmp-chi-top-102 (car syntmp-body-616) syntmp-r-617 syntmp-w-618 syntmp-m-619 syntmp-esew-620))) (cons syntmp-first-621 (syntmp-dobody-615 (cdr syntmp-body-616) syntmp-r-617 syntmp-w-618 syntmp-m-619 syntmp-esew-620)))))))) (syntmp-chi-sequence-97 (lambda (syntmp-body-622 syntmp-r-623 syntmp-w-624 syntmp-s-625) (syntmp-build-sequence-48 syntmp-s-625 (let syntmp-dobody-626 ((syntmp-body-627 syntmp-body-622) (syntmp-r-628 syntmp-r-623) (syntmp-w-629 syntmp-w-624)) (if (null? syntmp-body-627) (quote ()) (let ((syntmp-first-630 (syntmp-chi-103 (car syntmp-body-627) syntmp-r-628 syntmp-w-629))) (cons syntmp-first-630 (syntmp-dobody-626 (cdr syntmp-body-627) syntmp-r-628 syntmp-w-629)))))))) (syntmp-source-wrap-96 (lambda (syntmp-x-631 syntmp-w-632 syntmp-s-633) (syntmp-wrap-95 (if syntmp-s-633 (make-annotation syntmp-x-631 syntmp-s-633 (quote #f)) syntmp-x-631) syntmp-w-632))) (syntmp-wrap-95 (lambda (syntmp-x-634 syntmp-w-635) (cond ((and (null? (syntmp-wrap-marks-70 syntmp-w-635)) (null? (syntmp-wrap-subst-71 syntmp-w-635))) syntmp-x-634) ((syntmp-syntax-object?-53 syntmp-x-634) (syntmp-make-syntax-object-52 (syntmp-syntax-object-expression-54 syntmp-x-634) (syntmp-join-wraps-86 syntmp-w-635 (syntmp-syntax-object-wrap-55 syntmp-x-634)))) ((null? syntmp-x-634) syntmp-x-634) (else (syntmp-make-syntax-object-52 syntmp-x-634 syntmp-w-635))))) (syntmp-bound-id-member?-94 (lambda (syntmp-x-636 syntmp-list-637) (and (not (null? syntmp-list-637)) (or (syntmp-bound-id=?-91 syntmp-x-636 (car syntmp-list-637)) (syntmp-bound-id-member?-94 syntmp-x-636 (cdr syntmp-list-637)))))) (syntmp-distinct-bound-ids?-93 (lambda (syntmp-ids-638) (let syntmp-distinct?-639 ((syntmp-ids-640 syntmp-ids-638)) (or (null? syntmp-ids-640) (and (not (syntmp-bound-id-member?-94 (car syntmp-ids-640) (cdr syntmp-ids-640))) (syntmp-distinct?-639 (cdr syntmp-ids-640))))))) (syntmp-valid-bound-ids?-92 (lambda (syntmp-ids-641) (and (let syntmp-all-ids?-642 ((syntmp-ids-643 syntmp-ids-641)) (or (null? syntmp-ids-643) (and (syntmp-id?-67 (car syntmp-ids-643)) (syntmp-all-ids?-642 (cdr syntmp-ids-643))))) (syntmp-distinct-bound-ids?-93 syntmp-ids-641)))) (syntmp-bound-id=?-91 (lambda (syntmp-i-644 syntmp-j-645) (if (and (syntmp-syntax-object?-53 syntmp-i-644) (syntmp-syntax-object?-53 syntmp-j-645)) (and (eq? (let ((syntmp-e-646 (syntmp-syntax-object-expression-54 syntmp-i-644))) (if (syntmp-annotation?-42 syntmp-e-646) (annotation-expression syntmp-e-646) syntmp-e-646)) (let ((syntmp-e-647 (syntmp-syntax-object-expression-54 syntmp-j-645))) (if (syntmp-annotation?-42 syntmp-e-647) (annotation-expression syntmp-e-647) syntmp-e-647))) (syntmp-same-marks?-88 (syntmp-wrap-marks-70 (syntmp-syntax-object-wrap-55 syntmp-i-644)) (syntmp-wrap-marks-70 (syntmp-syntax-object-wrap-55 syntmp-j-645)))) (eq? (let ((syntmp-e-648 syntmp-i-644)) (if (syntmp-annotation?-42 syntmp-e-648) (annotation-expression syntmp-e-648) syntmp-e-648)) (let ((syntmp-e-649 syntmp-j-645)) (if (syntmp-annotation?-42 syntmp-e-649) (annotation-expression syntmp-e-649) syntmp-e-649)))))) (syntmp-free-id=?-90 (lambda (syntmp-i-650 syntmp-j-651) (and (eq? (let ((syntmp-x-652 syntmp-i-650)) (let ((syntmp-e-653 (if (syntmp-syntax-object?-53 syntmp-x-652) (syntmp-syntax-object-expression-54 syntmp-x-652) syntmp-x-652))) (if (syntmp-annotation?-42 syntmp-e-653) (annotation-expression syntmp-e-653) syntmp-e-653))) (let ((syntmp-x-654 syntmp-j-651)) (let ((syntmp-e-655 (if (syntmp-syntax-object?-53 syntmp-x-654) (syntmp-syntax-object-expression-54 syntmp-x-654) syntmp-x-654))) (if (syntmp-annotation?-42 syntmp-e-655) (annotation-expression syntmp-e-655) syntmp-e-655)))) (eq? (syntmp-id-var-name-89 syntmp-i-650 (quote (()))) (syntmp-id-var-name-89 syntmp-j-651 (quote (()))))))) (syntmp-id-var-name-89 (lambda (syntmp-id-656 syntmp-w-657) (letrec ((syntmp-search-vector-rib-660 (lambda (syntmp-sym-666 syntmp-subst-667 syntmp-marks-668 syntmp-symnames-669 syntmp-ribcage-670) (let ((syntmp-n-671 (vector-length syntmp-symnames-669))) (let syntmp-f-672 ((syntmp-i-673 (quote 0))) (cond ((syntmp-fx=-40 syntmp-i-673 syntmp-n-671) (syntmp-search-658 syntmp-sym-666 (cdr syntmp-subst-667) syntmp-marks-668)) ((and (eq? (vector-ref syntmp-symnames-669 syntmp-i-673) syntmp-sym-666) (syntmp-same-marks?-88 syntmp-marks-668 (vector-ref (syntmp-ribcage-marks-77 syntmp-ribcage-670) syntmp-i-673))) (values (vector-ref (syntmp-ribcage-labels-78 syntmp-ribcage-670) syntmp-i-673) syntmp-marks-668)) (else (syntmp-f-672 (syntmp-fx+-38 syntmp-i-673 (quote 1))))))))) (syntmp-search-list-rib-659 (lambda (syntmp-sym-674 syntmp-subst-675 syntmp-marks-676 syntmp-symnames-677 syntmp-ribcage-678) (let syntmp-f-679 ((syntmp-symnames-680 syntmp-symnames-677) (syntmp-i-681 (quote 0))) (cond ((null? syntmp-symnames-680) (syntmp-search-658 syntmp-sym-674 (cdr syntmp-subst-675) syntmp-marks-676)) ((and (eq? (car syntmp-symnames-680) syntmp-sym-674) (syntmp-same-marks?-88 syntmp-marks-676 (list-ref (syntmp-ribcage-marks-77 syntmp-ribcage-678) syntmp-i-681))) (values (list-ref (syntmp-ribcage-labels-78 syntmp-ribcage-678) syntmp-i-681) syntmp-marks-676)) (else (syntmp-f-679 (cdr syntmp-symnames-680) (syntmp-fx+-38 syntmp-i-681 (quote 1)))))))) (syntmp-search-658 (lambda (syntmp-sym-682 syntmp-subst-683 syntmp-marks-684) (if (null? syntmp-subst-683) (values (quote #f) syntmp-marks-684) (let ((syntmp-fst-685 (car syntmp-subst-683))) (if (eq? syntmp-fst-685 (quote shift)) (syntmp-search-658 syntmp-sym-682 (cdr syntmp-subst-683) (cdr syntmp-marks-684)) (let ((syntmp-symnames-686 (syntmp-ribcage-symnames-76 syntmp-fst-685))) (if (vector? syntmp-symnames-686) (syntmp-search-vector-rib-660 syntmp-sym-682 syntmp-subst-683 syntmp-marks-684 syntmp-symnames-686 syntmp-fst-685) (syntmp-search-list-rib-659 syntmp-sym-682 syntmp-subst-683 syntmp-marks-684 syntmp-symnames-686 syntmp-fst-685))))))))) (cond ((symbol? syntmp-id-656) (or (call-with-values (lambda () (syntmp-search-658 syntmp-id-656 (syntmp-wrap-subst-71 syntmp-w-657) (syntmp-wrap-marks-70 syntmp-w-657))) (lambda (syntmp-x-688 . syntmp-ignore-687) syntmp-x-688)) syntmp-id-656)) ((syntmp-syntax-object?-53 syntmp-id-656) (let ((syntmp-id-689 (let ((syntmp-e-691 (syntmp-syntax-object-expression-54 syntmp-id-656))) (if (syntmp-annotation?-42 syntmp-e-691) (annotation-expression syntmp-e-691) syntmp-e-691))) (syntmp-w1-690 (syntmp-syntax-object-wrap-55 syntmp-id-656))) (let ((syntmp-marks-692 (syntmp-join-marks-87 (syntmp-wrap-marks-70 syntmp-w-657) (syntmp-wrap-marks-70 syntmp-w1-690)))) (call-with-values (lambda () (syntmp-search-658 syntmp-id-689 (syntmp-wrap-subst-71 syntmp-w-657) syntmp-marks-692)) (lambda (syntmp-new-id-693 syntmp-marks-694) (or syntmp-new-id-693 (call-with-values (lambda () (syntmp-search-658 syntmp-id-689 (syntmp-wrap-subst-71 syntmp-w1-690) syntmp-marks-694)) (lambda (syntmp-x-696 . syntmp-ignore-695) syntmp-x-696)) syntmp-id-689)))))) ((syntmp-annotation?-42 syntmp-id-656) (let ((syntmp-id-697 (let ((syntmp-e-698 syntmp-id-656)) (if (syntmp-annotation?-42 syntmp-e-698) (annotation-expression syntmp-e-698) syntmp-e-698)))) (or (call-with-values (lambda () (syntmp-search-658 syntmp-id-697 (syntmp-wrap-subst-71 syntmp-w-657) (syntmp-wrap-marks-70 syntmp-w-657))) (lambda (syntmp-x-700 . syntmp-ignore-699) syntmp-x-700)) syntmp-id-697))) (else (syntmp-error-hook-45 (quote id-var-name) (quote "invalid id") syntmp-id-656)))))) (syntmp-same-marks?-88 (lambda (syntmp-x-701 syntmp-y-702) (or (eq? syntmp-x-701 syntmp-y-702) (and (not (null? syntmp-x-701)) (not (null? syntmp-y-702)) (eq? (car syntmp-x-701) (car syntmp-y-702)) (syntmp-same-marks?-88 (cdr syntmp-x-701) (cdr syntmp-y-702)))))) (syntmp-join-marks-87 (lambda (syntmp-m1-703 syntmp-m2-704) (syntmp-smart-append-85 syntmp-m1-703 syntmp-m2-704))) (syntmp-join-wraps-86 (lambda (syntmp-w1-705 syntmp-w2-706) (let ((syntmp-m1-707 (syntmp-wrap-marks-70 syntmp-w1-705)) (syntmp-s1-708 (syntmp-wrap-subst-71 syntmp-w1-705))) (if (null? syntmp-m1-707) (if (null? syntmp-s1-708) syntmp-w2-706 (syntmp-make-wrap-69 (syntmp-wrap-marks-70 syntmp-w2-706) (syntmp-smart-append-85 syntmp-s1-708 (syntmp-wrap-subst-71 syntmp-w2-706)))) (syntmp-make-wrap-69 (syntmp-smart-append-85 syntmp-m1-707 (syntmp-wrap-marks-70 syntmp-w2-706)) (syntmp-smart-append-85 syntmp-s1-708 (syntmp-wrap-subst-71 syntmp-w2-706))))))) (syntmp-smart-append-85 (lambda (syntmp-m1-709 syntmp-m2-710) (if (null? syntmp-m2-710) syntmp-m1-709 (append syntmp-m1-709 syntmp-m2-710)))) (syntmp-make-binding-wrap-84 (lambda (syntmp-ids-711 syntmp-labels-712 syntmp-w-713) (if (null? syntmp-ids-711) syntmp-w-713 (syntmp-make-wrap-69 (syntmp-wrap-marks-70 syntmp-w-713) (cons (let ((syntmp-labelvec-714 (list->vector syntmp-labels-712))) (let ((syntmp-n-715 (vector-length syntmp-labelvec-714))) (let ((syntmp-symnamevec-716 (make-vector syntmp-n-715)) (syntmp-marksvec-717 (make-vector syntmp-n-715))) (begin (let syntmp-f-718 ((syntmp-ids-719 syntmp-ids-711) (syntmp-i-720 (quote 0))) (if (not (null? syntmp-ids-719)) (call-with-values (lambda () (syntmp-id-sym-name&marks-68 (car syntmp-ids-719) syntmp-w-713)) (lambda (syntmp-symname-721 syntmp-marks-722) (begin (vector-set! syntmp-symnamevec-716 syntmp-i-720 syntmp-symname-721) (vector-set! syntmp-marksvec-717 syntmp-i-720 syntmp-marks-722) (syntmp-f-718 (cdr syntmp-ids-719) (syntmp-fx+-38 syntmp-i-720 (quote 1)))))))) (syntmp-make-ribcage-74 syntmp-symnamevec-716 syntmp-marksvec-717 syntmp-labelvec-714))))) (syntmp-wrap-subst-71 syntmp-w-713)))))) (syntmp-extend-ribcage!-83 (lambda (syntmp-ribcage-723 syntmp-id-724 syntmp-label-725) (begin (syntmp-set-ribcage-symnames!-79 syntmp-ribcage-723 (cons (let ((syntmp-e-726 (syntmp-syntax-object-expression-54 syntmp-id-724))) (if (syntmp-annotation?-42 syntmp-e-726) (annotation-expression syntmp-e-726) syntmp-e-726)) (syntmp-ribcage-symnames-76 syntmp-ribcage-723))) (syntmp-set-ribcage-marks!-80 syntmp-ribcage-723 (cons (syntmp-wrap-marks-70 (syntmp-syntax-object-wrap-55 syntmp-id-724)) (syntmp-ribcage-marks-77 syntmp-ribcage-723))) (syntmp-set-ribcage-labels!-81 syntmp-ribcage-723 (cons syntmp-label-725 (syntmp-ribcage-labels-78 syntmp-ribcage-723)))))) (syntmp-anti-mark-82 (lambda (syntmp-w-727) (syntmp-make-wrap-69 (cons (quote #f) (syntmp-wrap-marks-70 syntmp-w-727)) (cons (quote shift) (syntmp-wrap-subst-71 syntmp-w-727))))) (syntmp-set-ribcage-labels!-81 (lambda (syntmp-x-728 syntmp-update-729) (vector-set! syntmp-x-728 (quote 3) syntmp-update-729))) (syntmp-set-ribcage-marks!-80 (lambda (syntmp-x-730 syntmp-update-731) (vector-set! syntmp-x-730 (quote 2) syntmp-update-731))) (syntmp-set-ribcage-symnames!-79 (lambda (syntmp-x-732 syntmp-update-733) (vector-set! syntmp-x-732 (quote 1) syntmp-update-733))) (syntmp-ribcage-labels-78 (lambda (syntmp-x-734) (vector-ref syntmp-x-734 (quote 3)))) (syntmp-ribcage-marks-77 (lambda (syntmp-x-735) (vector-ref syntmp-x-735 (quote 2)))) (syntmp-ribcage-symnames-76 (lambda (syntmp-x-736) (vector-ref syntmp-x-736 (quote 1)))) (syntmp-ribcage?-75 (lambda (syntmp-x-737) (and (vector? syntmp-x-737) (= (vector-length syntmp-x-737) (quote 4)) (eq? (vector-ref syntmp-x-737 (quote 0)) (quote ribcage))))) (syntmp-make-ribcage-74 (lambda (syntmp-symnames-738 syntmp-marks-739 syntmp-labels-740) (vector (quote ribcage) syntmp-symnames-738 syntmp-marks-739 syntmp-labels-740))) (syntmp-gen-labels-73 (lambda (syntmp-ls-741) (if (null? syntmp-ls-741) (quote ()) (cons (syntmp-gen-label-72) (syntmp-gen-labels-73 (cdr syntmp-ls-741)))))) (syntmp-gen-label-72 (lambda () (string (quote #\i)))) (syntmp-wrap-subst-71 cdr) (syntmp-wrap-marks-70 car) (syntmp-make-wrap-69 cons) (syntmp-id-sym-name&marks-68 (lambda (syntmp-x-742 syntmp-w-743) (if (syntmp-syntax-object?-53 syntmp-x-742) (values (let ((syntmp-e-744 (syntmp-syntax-object-expression-54 syntmp-x-742))) (if (syntmp-annotation?-42 syntmp-e-744) (annotation-expression syntmp-e-744) syntmp-e-744)) (syntmp-join-marks-87 (syntmp-wrap-marks-70 syntmp-w-743) (syntmp-wrap-marks-70 (syntmp-syntax-object-wrap-55 syntmp-x-742)))) (values (let ((syntmp-e-745 syntmp-x-742)) (if (syntmp-annotation?-42 syntmp-e-745) (annotation-expression syntmp-e-745) syntmp-e-745)) (syntmp-wrap-marks-70 syntmp-w-743))))) (syntmp-id?-67 (lambda (syntmp-x-746) (cond ((symbol? syntmp-x-746) (quote #t)) ((syntmp-syntax-object?-53 syntmp-x-746) (symbol? (let ((syntmp-e-747 (syntmp-syntax-object-expression-54 syntmp-x-746))) (if (syntmp-annotation?-42 syntmp-e-747) (annotation-expression syntmp-e-747) syntmp-e-747)))) ((syntmp-annotation?-42 syntmp-x-746) (symbol? (annotation-expression syntmp-x-746))) (else (quote #f))))) (syntmp-nonsymbol-id?-66 (lambda (syntmp-x-748) (and (syntmp-syntax-object?-53 syntmp-x-748) (symbol? (let ((syntmp-e-749 (syntmp-syntax-object-expression-54 syntmp-x-748))) (if (syntmp-annotation?-42 syntmp-e-749) (annotation-expression syntmp-e-749) syntmp-e-749)))))) (syntmp-global-extend-65 (lambda (syntmp-type-750 syntmp-sym-751 syntmp-val-752) (syntmp-put-global-definition-hook-46 syntmp-sym-751 (cons syntmp-type-750 syntmp-val-752)))) (syntmp-lookup-64 (lambda (syntmp-x-753 syntmp-r-754) (cond ((assq syntmp-x-753 syntmp-r-754) => cdr) ((symbol? syntmp-x-753) (or (syntmp-get-global-definition-hook-47 syntmp-x-753) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-63 (lambda (syntmp-r-755) (if (null? syntmp-r-755) (quote ()) (let ((syntmp-a-756 (car syntmp-r-755))) (if (eq? (cadr syntmp-a-756) (quote macro)) (cons syntmp-a-756 (syntmp-macros-only-env-63 (cdr syntmp-r-755))) (syntmp-macros-only-env-63 (cdr syntmp-r-755))))))) (syntmp-extend-var-env-62 (lambda (syntmp-labels-757 syntmp-vars-758 syntmp-r-759) (if (null? syntmp-labels-757) syntmp-r-759 (syntmp-extend-var-env-62 (cdr syntmp-labels-757) (cdr syntmp-vars-758) (cons (cons (car syntmp-labels-757) (cons (quote lexical) (car syntmp-vars-758))) syntmp-r-759))))) (syntmp-extend-env-61 (lambda (syntmp-labels-760 syntmp-bindings-761 syntmp-r-762) (if (null? syntmp-labels-760) syntmp-r-762 (syntmp-extend-env-61 (cdr syntmp-labels-760) (cdr syntmp-bindings-761) (cons (cons (car syntmp-labels-760) (car syntmp-bindings-761)) syntmp-r-762))))) (syntmp-binding-value-60 cdr) (syntmp-binding-type-59 car) (syntmp-source-annotation-58 (lambda (syntmp-x-763) (cond ((syntmp-annotation?-42 syntmp-x-763) (annotation-source syntmp-x-763)) ((syntmp-syntax-object?-53 syntmp-x-763) (syntmp-source-annotation-58 (syntmp-syntax-object-expression-54 syntmp-x-763))) (else (quote #f))))) (syntmp-set-syntax-object-wrap!-57 (lambda (syntmp-x-764 syntmp-update-765) (vector-set! syntmp-x-764 (quote 2) syntmp-update-765))) (syntmp-set-syntax-object-expression!-56 (lambda (syntmp-x-766 syntmp-update-767) (vector-set! syntmp-x-766 (quote 1) syntmp-update-767))) (syntmp-syntax-object-wrap-55 (lambda (syntmp-x-768) (vector-ref syntmp-x-768 (quote 2)))) (syntmp-syntax-object-expression-54 (lambda (syntmp-x-769) (vector-ref syntmp-x-769 (quote 1)))) (syntmp-syntax-object?-53 (lambda (syntmp-x-770) (and (vector? syntmp-x-770) (= (vector-length syntmp-x-770) (quote 3)) (eq? (vector-ref syntmp-x-770 (quote 0)) (quote syntax-object))))) (syntmp-make-syntax-object-52 (lambda (syntmp-expression-771 syntmp-wrap-772) (vector (quote syntax-object) syntmp-expression-771 syntmp-wrap-772))) (syntmp-build-letrec-51 (lambda (syntmp-src-773 syntmp-vars-774 syntmp-val-exps-775 syntmp-body-exp-776) (if (null? syntmp-vars-774) syntmp-body-exp-776 (list (quote letrec) (map list syntmp-vars-774 syntmp-val-exps-775) syntmp-body-exp-776)))) (syntmp-build-named-let-50 (lambda (syntmp-src-777 syntmp-vars-778 syntmp-val-exps-779 syntmp-body-exp-780) (if (null? syntmp-vars-778) syntmp-body-exp-780 (list (quote let) (car syntmp-vars-778) (map list (cdr syntmp-vars-778) syntmp-val-exps-779) syntmp-body-exp-780)))) (syntmp-build-let-49 (lambda (syntmp-src-781 syntmp-vars-782 syntmp-val-exps-783 syntmp-body-exp-784) (if (null? syntmp-vars-782) syntmp-body-exp-784 (list (quote let) (map list syntmp-vars-782 syntmp-val-exps-783) syntmp-body-exp-784)))) (syntmp-build-sequence-48 (lambda (syntmp-src-785 syntmp-exps-786) (if (null? (cdr syntmp-exps-786)) (car syntmp-exps-786) (cons (quote begin) syntmp-exps-786)))) (syntmp-get-global-definition-hook-47 (lambda (syntmp-symbol-787) (getprop syntmp-symbol-787 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-46 (lambda (syntmp-symbol-788 syntmp-binding-789) (putprop syntmp-symbol-788 (quote *sc-expander*) syntmp-binding-789))) (syntmp-error-hook-45 (lambda (syntmp-who-790 syntmp-why-791 syntmp-what-792) (error syntmp-who-790 (quote "~a ~s") syntmp-why-791 syntmp-what-792))) (syntmp-local-eval-hook-44 (lambda (syntmp-x-793) (eval (list syntmp-noexpand-37 syntmp-x-793) (interaction-environment)))) (syntmp-top-level-eval-hook-43 (lambda (syntmp-x-794) (eval (list syntmp-noexpand-37 syntmp-x-794) (interaction-environment)))) (syntmp-annotation?-42 (lambda (syntmp-x-795) (quote #f))) (syntmp-fx<-41 <) (syntmp-fx=-40 =) (syntmp-fx--39 -) (syntmp-fx+-38 +) (syntmp-noexpand-37 (quote "noexpand"))) (begin (syntmp-global-extend-65 (quote local-syntax) (quote letrec-syntax) (quote #t)) (syntmp-global-extend-65 (quote local-syntax) (quote let-syntax) (quote #f)) (syntmp-global-extend-65 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-796 syntmp-r-797 syntmp-w-798 syntmp-s-799) ((lambda (syntmp-tmp-800) ((lambda (syntmp-tmp-801) (if (if syntmp-tmp-801 (apply (lambda (syntmp-_-802 syntmp-var-803 syntmp-val-804 syntmp-e1-805 syntmp-e2-806) (syntmp-valid-bound-ids?-92 syntmp-var-803)) syntmp-tmp-801) (quote #f)) (apply (lambda (syntmp-_-808 syntmp-var-809 syntmp-val-810 syntmp-e1-811 syntmp-e2-812) (let ((syntmp-names-813 (map (lambda (syntmp-x-814) (syntmp-id-var-name-89 syntmp-x-814 syntmp-w-798)) syntmp-var-809))) (begin (for-each (lambda (syntmp-id-816 syntmp-n-817) (let ((syntmp-t-818 (syntmp-binding-type-59 (syntmp-lookup-64 syntmp-n-817 syntmp-r-797)))) (if (memv syntmp-t-818 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-96 syntmp-id-816 syntmp-w-798 syntmp-s-799) (quote "identifier out of context"))))) syntmp-var-809 syntmp-names-813) (syntmp-chi-body-107 (cons syntmp-e1-811 syntmp-e2-812) (syntmp-source-wrap-96 syntmp-e-796 syntmp-w-798 syntmp-s-799) (syntmp-extend-env-61 syntmp-names-813 (let ((syntmp-trans-r-821 (syntmp-macros-only-env-63 syntmp-r-797))) (map (lambda (syntmp-x-822) (cons (quote macro) (syntmp-eval-local-transformer-110 (syntmp-chi-103 syntmp-x-822 syntmp-trans-r-821 syntmp-w-798)))) syntmp-val-810)) syntmp-r-797) syntmp-w-798)))) syntmp-tmp-801) ((lambda (syntmp-_-824) (syntax-error (syntmp-source-wrap-96 syntmp-e-796 syntmp-w-798 syntmp-s-799))) syntmp-tmp-800))) (syntax-dispatch syntmp-tmp-800 (quote (any #(each (any any)) any . each-any))))) syntmp-e-796))) (syntmp-global-extend-65 (quote core) (quote quote) (lambda (syntmp-e-825 syntmp-r-826 syntmp-w-827 syntmp-s-828) ((lambda (syntmp-tmp-829) ((lambda (syntmp-tmp-830) (if syntmp-tmp-830 (apply (lambda (syntmp-_-831 syntmp-e-832) (list (quote quote) (syntmp-strip-114 syntmp-e-832 syntmp-w-827))) syntmp-tmp-830) ((lambda (syntmp-_-833) (syntax-error (syntmp-source-wrap-96 syntmp-e-825 syntmp-w-827 syntmp-s-828))) syntmp-tmp-829))) (syntax-dispatch syntmp-tmp-829 (quote (any any))))) syntmp-e-825))) (syntmp-global-extend-65 (quote core) (quote syntax) (letrec ((syntmp-regen-841 (lambda (syntmp-x-842) (let ((syntmp-t-843 (car syntmp-x-842))) (if (memv syntmp-t-843 (quote (ref))) (cadr syntmp-x-842) (if (memv syntmp-t-843 (quote (primitive))) (cadr syntmp-x-842) (if (memv syntmp-t-843 (quote (quote))) (list (quote quote) (cadr syntmp-x-842)) (if (memv syntmp-t-843 (quote (lambda))) (list (quote lambda) (cadr syntmp-x-842) (syntmp-regen-841 (caddr syntmp-x-842))) (if (memv syntmp-t-843 (quote (map))) (let ((syntmp-ls-844 (map syntmp-regen-841 (cdr syntmp-x-842)))) (cons (if (syntmp-fx=-40 (length syntmp-ls-844) (quote 2)) (quote map) (quote map)) syntmp-ls-844)) (cons (car syntmp-x-842) (map syntmp-regen-841 (cdr syntmp-x-842))))))))))) (syntmp-gen-vector-840 (lambda (syntmp-x-845) (cond ((eq? (car syntmp-x-845) (quote list)) (cons (quote vector) (cdr syntmp-x-845))) ((eq? (car syntmp-x-845) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-845)))) (else (list (quote list->vector) syntmp-x-845))))) (syntmp-gen-append-839 (lambda (syntmp-x-846 syntmp-y-847) (if (equal? syntmp-y-847 (quote (quote ()))) syntmp-x-846 (list (quote append) syntmp-x-846 syntmp-y-847)))) (syntmp-gen-cons-838 (lambda (syntmp-x-848 syntmp-y-849) (let ((syntmp-t-850 (car syntmp-y-849))) (if (memv syntmp-t-850 (quote (quote))) (if (eq? (car syntmp-x-848) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-848) (cadr syntmp-y-849))) (if (eq? (cadr syntmp-y-849) (quote ())) (list (quote list) syntmp-x-848) (list (quote cons) syntmp-x-848 syntmp-y-849))) (if (memv syntmp-t-850 (quote (list))) (cons (quote list) (cons syntmp-x-848 (cdr syntmp-y-849))) (list (quote cons) syntmp-x-848 syntmp-y-849)))))) (syntmp-gen-map-837 (lambda (syntmp-e-851 syntmp-map-env-852) (let ((syntmp-formals-853 (map cdr syntmp-map-env-852)) (syntmp-actuals-854 (map (lambda (syntmp-x-855) (list (quote ref) (car syntmp-x-855))) syntmp-map-env-852))) (cond ((eq? (car syntmp-e-851) (quote ref)) (car syntmp-actuals-854)) ((andmap (lambda (syntmp-x-856) (and (eq? (car syntmp-x-856) (quote ref)) (memq (cadr syntmp-x-856) syntmp-formals-853))) (cdr syntmp-e-851)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-851)) (map (let ((syntmp-r-857 (map cons syntmp-formals-853 syntmp-actuals-854))) (lambda (syntmp-x-858) (cdr (assq (cadr syntmp-x-858) syntmp-r-857)))) (cdr syntmp-e-851))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-853 syntmp-e-851) syntmp-actuals-854))))))) (syntmp-gen-mappend-836 (lambda (syntmp-e-859 syntmp-map-env-860) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-837 syntmp-e-859 syntmp-map-env-860)))) (syntmp-gen-ref-835 (lambda (syntmp-src-861 syntmp-var-862 syntmp-level-863 syntmp-maps-864) (if (syntmp-fx=-40 syntmp-level-863 (quote 0)) (values syntmp-var-862 syntmp-maps-864) (if (null? syntmp-maps-864) (syntax-error syntmp-src-861 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (syntmp-gen-ref-835 syntmp-src-861 syntmp-var-862 (syntmp-fx--39 syntmp-level-863 (quote 1)) (cdr syntmp-maps-864))) (lambda (syntmp-outer-var-865 syntmp-outer-maps-866) (let ((syntmp-b-867 (assq syntmp-outer-var-865 (car syntmp-maps-864)))) (if syntmp-b-867 (values (cdr syntmp-b-867) syntmp-maps-864) (let ((syntmp-inner-var-868 (syntmp-gen-var-115 (quote tmp)))) (values syntmp-inner-var-868 (cons (cons (cons syntmp-outer-var-865 syntmp-inner-var-868) (car syntmp-maps-864)) syntmp-outer-maps-866))))))))))) (syntmp-gen-syntax-834 (lambda (syntmp-src-869 syntmp-e-870 syntmp-r-871 syntmp-maps-872 syntmp-ellipsis?-873) (if (syntmp-id?-67 syntmp-e-870) (let ((syntmp-label-874 (syntmp-id-var-name-89 syntmp-e-870 (quote (()))))) (let ((syntmp-b-875 (syntmp-lookup-64 syntmp-label-874 syntmp-r-871))) (if (eq? (syntmp-binding-type-59 syntmp-b-875) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-876 (syntmp-binding-value-60 syntmp-b-875))) (syntmp-gen-ref-835 syntmp-src-869 (car syntmp-var.lev-876) (cdr syntmp-var.lev-876) syntmp-maps-872))) (lambda (syntmp-var-877 syntmp-maps-878) (values (list (quote ref) syntmp-var-877) syntmp-maps-878))) (if (syntmp-ellipsis?-873 syntmp-e-870) (syntax-error syntmp-src-869 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) syntmp-e-870) syntmp-maps-872))))) ((lambda (syntmp-tmp-879) ((lambda (syntmp-tmp-880) (if (if syntmp-tmp-880 (apply (lambda (syntmp-dots-881 syntmp-e-882) (syntmp-ellipsis?-873 syntmp-dots-881)) syntmp-tmp-880) (quote #f)) (apply (lambda (syntmp-dots-883 syntmp-e-884) (syntmp-gen-syntax-834 syntmp-src-869 syntmp-e-884 syntmp-r-871 syntmp-maps-872 (lambda (syntmp-x-885) (quote #f)))) syntmp-tmp-880) ((lambda (syntmp-tmp-886) (if (if syntmp-tmp-886 (apply (lambda (syntmp-x-887 syntmp-dots-888 syntmp-y-889) (syntmp-ellipsis?-873 syntmp-dots-888)) syntmp-tmp-886) (quote #f)) (apply (lambda (syntmp-x-890 syntmp-dots-891 syntmp-y-892) (let syntmp-f-893 ((syntmp-y-894 syntmp-y-892) (syntmp-k-895 (lambda (syntmp-maps-896) (call-with-values (lambda () (syntmp-gen-syntax-834 syntmp-src-869 syntmp-x-890 syntmp-r-871 (cons (quote ()) syntmp-maps-896) syntmp-ellipsis?-873)) (lambda (syntmp-x-897 syntmp-maps-898) (if (null? (car syntmp-maps-898)) (syntax-error syntmp-src-869 (quote "extra ellipsis in syntax form")) (values (syntmp-gen-map-837 syntmp-x-897 (car syntmp-maps-898)) (cdr syntmp-maps-898)))))))) ((lambda (syntmp-tmp-899) ((lambda (syntmp-tmp-900) (if (if syntmp-tmp-900 (apply (lambda (syntmp-dots-901 syntmp-y-902) (syntmp-ellipsis?-873 syntmp-dots-901)) syntmp-tmp-900) (quote #f)) (apply (lambda (syntmp-dots-903 syntmp-y-904) (syntmp-f-893 syntmp-y-904 (lambda (syntmp-maps-905) (call-with-values (lambda () (syntmp-k-895 (cons (quote ()) syntmp-maps-905))) (lambda (syntmp-x-906 syntmp-maps-907) (if (null? (car syntmp-maps-907)) (syntax-error syntmp-src-869 (quote "extra ellipsis in syntax form")) (values (syntmp-gen-mappend-836 syntmp-x-906 (car syntmp-maps-907)) (cdr syntmp-maps-907)))))))) syntmp-tmp-900) ((lambda (syntmp-_-908) (call-with-values (lambda () (syntmp-gen-syntax-834 syntmp-src-869 syntmp-y-894 syntmp-r-871 syntmp-maps-872 syntmp-ellipsis?-873)) (lambda (syntmp-y-909 syntmp-maps-910) (call-with-values (lambda () (syntmp-k-895 syntmp-maps-910)) (lambda (syntmp-x-911 syntmp-maps-912) (values (syntmp-gen-append-839 syntmp-x-911 syntmp-y-909) syntmp-maps-912)))))) syntmp-tmp-899))) (syntax-dispatch syntmp-tmp-899 (quote (any . any))))) syntmp-y-894))) syntmp-tmp-886) ((lambda (syntmp-tmp-913) (if syntmp-tmp-913 (apply (lambda (syntmp-x-914 syntmp-y-915) (call-with-values (lambda () (syntmp-gen-syntax-834 syntmp-src-869 syntmp-x-914 syntmp-r-871 syntmp-maps-872 syntmp-ellipsis?-873)) (lambda (syntmp-x-916 syntmp-maps-917) (call-with-values (lambda () (syntmp-gen-syntax-834 syntmp-src-869 syntmp-y-915 syntmp-r-871 syntmp-maps-917 syntmp-ellipsis?-873)) (lambda (syntmp-y-918 syntmp-maps-919) (values (syntmp-gen-cons-838 syntmp-x-916 syntmp-y-918) syntmp-maps-919)))))) syntmp-tmp-913) ((lambda (syntmp-tmp-920) (if syntmp-tmp-920 (apply (lambda (syntmp-e1-921 syntmp-e2-922) (call-with-values (lambda () (syntmp-gen-syntax-834 syntmp-src-869 (cons syntmp-e1-921 syntmp-e2-922) syntmp-r-871 syntmp-maps-872 syntmp-ellipsis?-873)) (lambda (syntmp-e-924 syntmp-maps-925) (values (syntmp-gen-vector-840 syntmp-e-924) syntmp-maps-925)))) syntmp-tmp-920) ((lambda (syntmp-_-926) (values (list (quote quote) syntmp-e-870) syntmp-maps-872)) syntmp-tmp-879))) (syntax-dispatch syntmp-tmp-879 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-879 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-879 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-879 (quote (any any))))) syntmp-e-870))))) (lambda (syntmp-e-927 syntmp-r-928 syntmp-w-929 syntmp-s-930) (let ((syntmp-e-931 (syntmp-source-wrap-96 syntmp-e-927 syntmp-w-929 syntmp-s-930))) ((lambda (syntmp-tmp-932) ((lambda (syntmp-tmp-933) (if syntmp-tmp-933 (apply (lambda (syntmp-_-934 syntmp-x-935) (call-with-values (lambda () (syntmp-gen-syntax-834 syntmp-e-931 syntmp-x-935 syntmp-r-928 (quote ()) syntmp-ellipsis?-112)) (lambda (syntmp-e-936 syntmp-maps-937) (syntmp-regen-841 syntmp-e-936)))) syntmp-tmp-933) ((lambda (syntmp-_-938) (syntax-error syntmp-e-931)) syntmp-tmp-932))) (syntax-dispatch syntmp-tmp-932 (quote (any any))))) syntmp-e-931))))) (syntmp-global-extend-65 (quote core) (quote lambda) (lambda (syntmp-e-939 syntmp-r-940 syntmp-w-941 syntmp-s-942) ((lambda (syntmp-tmp-943) ((lambda (syntmp-tmp-944) (if syntmp-tmp-944 (apply (lambda (syntmp-_-945 syntmp-c-946) (syntmp-chi-lambda-clause-108 (syntmp-source-wrap-96 syntmp-e-939 syntmp-w-941 syntmp-s-942) syntmp-c-946 syntmp-r-940 syntmp-w-941 (lambda (syntmp-vars-947 syntmp-body-948) (list (quote lambda) syntmp-vars-947 syntmp-body-948)))) syntmp-tmp-944) (syntax-error syntmp-tmp-943))) (syntax-dispatch syntmp-tmp-943 (quote (any . any))))) syntmp-e-939))) (syntmp-global-extend-65 (quote core) (quote let) (letrec ((syntmp-chi-let-949 (lambda (syntmp-e-950 syntmp-r-951 syntmp-w-952 syntmp-s-953 syntmp-constructor-954 syntmp-ids-955 syntmp-vals-956 syntmp-exps-957) (if (not (syntmp-valid-bound-ids?-92 syntmp-ids-955)) (syntax-error syntmp-e-950 (quote "duplicate bound variable in")) (let ((syntmp-labels-958 (syntmp-gen-labels-73 syntmp-ids-955)) (syntmp-new-vars-959 (map syntmp-gen-var-115 syntmp-ids-955))) (let ((syntmp-nw-960 (syntmp-make-binding-wrap-84 syntmp-ids-955 syntmp-labels-958 syntmp-w-952)) (syntmp-nr-961 (syntmp-extend-var-env-62 syntmp-labels-958 syntmp-new-vars-959 syntmp-r-951))) (syntmp-constructor-954 syntmp-s-953 syntmp-new-vars-959 (map (lambda (syntmp-x-962) (syntmp-chi-103 syntmp-x-962 syntmp-r-951 syntmp-w-952)) syntmp-vals-956) (syntmp-chi-body-107 syntmp-exps-957 (syntmp-source-wrap-96 syntmp-e-950 syntmp-nw-960 syntmp-s-953) syntmp-nr-961 syntmp-nw-960)))))))) (lambda (syntmp-e-963 syntmp-r-964 syntmp-w-965 syntmp-s-966) ((lambda (syntmp-tmp-967) ((lambda (syntmp-tmp-968) (if syntmp-tmp-968 (apply (lambda (syntmp-_-969 syntmp-id-970 syntmp-val-971 syntmp-e1-972 syntmp-e2-973) (syntmp-chi-let-949 syntmp-e-963 syntmp-r-964 syntmp-w-965 syntmp-s-966 syntmp-build-let-49 syntmp-id-970 syntmp-val-971 (cons syntmp-e1-972 syntmp-e2-973))) syntmp-tmp-968) ((lambda (syntmp-tmp-977) (if (if syntmp-tmp-977 (apply (lambda (syntmp-_-978 syntmp-f-979 syntmp-id-980 syntmp-val-981 syntmp-e1-982 syntmp-e2-983) (syntmp-id?-67 syntmp-f-979)) syntmp-tmp-977) (quote #f)) (apply (lambda (syntmp-_-984 syntmp-f-985 syntmp-id-986 syntmp-val-987 syntmp-e1-988 syntmp-e2-989) (syntmp-chi-let-949 syntmp-e-963 syntmp-r-964 syntmp-w-965 syntmp-s-966 syntmp-build-named-let-50 (cons syntmp-f-985 syntmp-id-986) syntmp-val-987 (cons syntmp-e1-988 syntmp-e2-989))) syntmp-tmp-977) ((lambda (syntmp-_-993) (syntax-error (syntmp-source-wrap-96 syntmp-e-963 syntmp-w-965 syntmp-s-966))) syntmp-tmp-967))) (syntax-dispatch syntmp-tmp-967 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-967 (quote (any #(each (any any)) any . each-any))))) syntmp-e-963)))) (syntmp-global-extend-65 (quote core) (quote letrec) (lambda (syntmp-e-994 syntmp-r-995 syntmp-w-996 syntmp-s-997) ((lambda (syntmp-tmp-998) ((lambda (syntmp-tmp-999) (if syntmp-tmp-999 (apply (lambda (syntmp-_-1000 syntmp-id-1001 syntmp-val-1002 syntmp-e1-1003 syntmp-e2-1004) (let ((syntmp-ids-1005 syntmp-id-1001)) (if (not (syntmp-valid-bound-ids?-92 syntmp-ids-1005)) (syntax-error syntmp-e-994 (quote "duplicate bound variable in")) (let ((syntmp-labels-1007 (syntmp-gen-labels-73 syntmp-ids-1005)) (syntmp-new-vars-1008 (map syntmp-gen-var-115 syntmp-ids-1005))) (let ((syntmp-w-1009 (syntmp-make-binding-wrap-84 syntmp-ids-1005 syntmp-labels-1007 syntmp-w-996)) (syntmp-r-1010 (syntmp-extend-var-env-62 syntmp-labels-1007 syntmp-new-vars-1008 syntmp-r-995))) (syntmp-build-letrec-51 syntmp-s-997 syntmp-new-vars-1008 (map (lambda (syntmp-x-1011) (syntmp-chi-103 syntmp-x-1011 syntmp-r-1010 syntmp-w-1009)) syntmp-val-1002) (syntmp-chi-body-107 (cons syntmp-e1-1003 syntmp-e2-1004) (syntmp-source-wrap-96 syntmp-e-994 syntmp-w-1009 syntmp-s-997) syntmp-r-1010 syntmp-w-1009))))))) syntmp-tmp-999) ((lambda (syntmp-_-1014) (syntax-error (syntmp-source-wrap-96 syntmp-e-994 syntmp-w-996 syntmp-s-997))) syntmp-tmp-998))) (syntax-dispatch syntmp-tmp-998 (quote (any #(each (any any)) any . each-any))))) syntmp-e-994))) (syntmp-global-extend-65 (quote core) (quote set!) (lambda (syntmp-e-1015 syntmp-r-1016 syntmp-w-1017 syntmp-s-1018) ((lambda (syntmp-tmp-1019) ((lambda (syntmp-tmp-1020) (if (if syntmp-tmp-1020 (apply (lambda (syntmp-_-1021 syntmp-id-1022 syntmp-val-1023) (syntmp-id?-67 syntmp-id-1022)) syntmp-tmp-1020) (quote #f)) (apply (lambda (syntmp-_-1024 syntmp-id-1025 syntmp-val-1026) (let ((syntmp-val-1027 (syntmp-chi-103 syntmp-val-1026 syntmp-r-1016 syntmp-w-1017)) (syntmp-n-1028 (syntmp-id-var-name-89 syntmp-id-1025 syntmp-w-1017))) (let ((syntmp-b-1029 (syntmp-lookup-64 syntmp-n-1028 syntmp-r-1016))) (let ((syntmp-t-1030 (syntmp-binding-type-59 syntmp-b-1029))) (if (memv syntmp-t-1030 (quote (lexical))) (list (quote set!) (syntmp-binding-value-60 syntmp-b-1029) syntmp-val-1027) (if (memv syntmp-t-1030 (quote (global))) (list (quote set!) syntmp-n-1028 syntmp-val-1027) (if (memv syntmp-t-1030 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-95 syntmp-id-1025 syntmp-w-1017) (quote "identifier out of context")) (syntax-error (syntmp-source-wrap-96 syntmp-e-1015 syntmp-w-1017 syntmp-s-1018))))))))) syntmp-tmp-1020) ((lambda (syntmp-tmp-1031) (if syntmp-tmp-1031 (apply (lambda (syntmp-_-1032 syntmp-getter-1033 syntmp-arg-1034 syntmp-val-1035) (cons (syntmp-chi-103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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"))))) syntmp-getter-1033) syntmp-r-1016 syntmp-w-1017) (map (lambda (syntmp-e-1036) (syntmp-chi-103 syntmp-e-1036 syntmp-r-1016 syntmp-w-1017)) (append syntmp-arg-1034 (list syntmp-val-1035))))) syntmp-tmp-1031) ((lambda (syntmp-_-1038) (syntax-error (syntmp-source-wrap-96 syntmp-e-1015 syntmp-w-1017 syntmp-s-1018))) syntmp-tmp-1019))) (syntax-dispatch syntmp-tmp-1019 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1019 (quote (any any any))))) syntmp-e-1015))) (syntmp-global-extend-65 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-65 (quote define) (quote define) (quote ())) (syntmp-global-extend-65 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-65 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-65 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1042 (lambda (syntmp-x-1043 syntmp-keys-1044 syntmp-clauses-1045 syntmp-r-1046) (if (null? syntmp-clauses-1045) (list (quote syntax-error) syntmp-x-1043) ((lambda (syntmp-tmp-1047) ((lambda (syntmp-tmp-1048) (if syntmp-tmp-1048 (apply (lambda (syntmp-pat-1049 syntmp-exp-1050) (if (and (syntmp-id?-67 syntmp-pat-1049) (andmap (lambda (syntmp-x-1051) (not (syntmp-free-id=?-90 syntmp-pat-1049 syntmp-x-1051))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("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-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? 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)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "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"))))) syntmp-keys-1044))) (let ((syntmp-labels-1052 (list (syntmp-gen-label-72))) (syntmp-var-1053 (syntmp-gen-var-115 syntmp-pat-1049))) (list (list (quote lambda) (list syntmp-var-1053) (syntmp-chi-103 syntmp-exp-1050 (syntmp-extend-env-61 syntmp-labels-1052 (list (cons (quote syntax) (cons syntmp-var-1053 (quote 0)))) syntmp-r-1046) (syntmp-make-binding-wrap-84 (list syntmp-pat-1049) syntmp-labels-1052 (quote (()))))) syntmp-x-1043)) (syntmp-gen-clause-1041 syntmp-x-1043 syntmp-keys-1044 (cdr syntmp-clauses-1045) syntmp-r-1046 syntmp-pat-1049 (quote #t) syntmp-exp-1050))) syntmp-tmp-1048) ((lambda (syntmp-tmp-1054) (if syntmp-tmp-1054 (apply (lambda (syntmp-pat-1055 syntmp-fender-1056 syntmp-exp-1057) (syntmp-gen-clause-1041 syntmp-x-1043 syntmp-keys-1044 (cdr syntmp-clauses-1045) syntmp-r-1046 syntmp-pat-1055 syntmp-fender-1056 syntmp-exp-1057)) syntmp-tmp-1054) ((lambda (syntmp-_-1058) (syntax-error (car syntmp-clauses-1045) (quote "invalid syntax-case clause"))) syntmp-tmp-1047))) (syntax-dispatch syntmp-tmp-1047 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1047 (quote (any any))))) (car syntmp-clauses-1045))))) (syntmp-gen-clause-1041 (lambda (syntmp-x-1059 syntmp-keys-1060 syntmp-clauses-1061 syntmp-r-1062 syntmp-pat-1063 syntmp-fender-1064 syntmp-exp-1065) (call-with-values (lambda () (syntmp-convert-pattern-1039 syntmp-pat-1063 syntmp-keys-1060)) (lambda (syntmp-p-1066 syntmp-pvars-1067) (cond ((not (syntmp-distinct-bound-ids?-93 (map car syntmp-pvars-1067))) (syntax-error syntmp-pat-1063 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (syntmp-x-1068) (not (syntmp-ellipsis?-112 (car syntmp-x-1068)))) syntmp-pvars-1067)) (syntax-error syntmp-pat-1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((syntmp-y-1069 (syntmp-gen-var-115 (quote tmp)))) (list (list (quote lambda) (list syntmp-y-1069) (let ((syntmp-y-1070 syntmp-y-1069)) (list (quote if) ((lambda (syntmp-tmp-1071) ((lambda (syntmp-tmp-1072) (if syntmp-tmp-1072 (apply (lambda () syntmp-y-1070) syntmp-tmp-1072) ((lambda (syntmp-_-1073) (list (quote if) syntmp-y-1070 (syntmp-build-dispatch-call-1040 syntmp-pvars-1067 syntmp-fender-1064 syntmp-y-1070 syntmp-r-1062) (list (quote quote) (quote #f)))) syntmp-tmp-1071))) (syntax-dispatch syntmp-tmp-1071 (quote #(atom #t))))) syntmp-fender-1064) (syntmp-build-dispatch-call-1040 syntmp-pvars-1067 syntmp-exp-1065 syntmp-y-1070 syntmp-r-1062) (syntmp-gen-syntax-case-1042 syntmp-x-1059 syntmp-keys-1060 syntmp-clauses-1061 syntmp-r-1062)))) (if (eq? syntmp-p-1066 (quote any)) (list (quote list) syntmp-x-1059) (list (quote syntax-dispatch) syntmp-x-1059 (list (quote quote) syntmp-p-1066))))))))))) (syntmp-build-dispatch-call-1040 (lambda (syntmp-pvars-1074 syntmp-exp-1075 syntmp-y-1076 syntmp-r-1077) (let ((syntmp-ids-1078 (map car syntmp-pvars-1074)) (syntmp-levels-1079 (map cdr syntmp-pvars-1074))) (let ((syntmp-labels-1080 (syntmp-gen-labels-73 syntmp-ids-1078)) (syntmp-new-vars-1081 (map syntmp-gen-var-115 syntmp-ids-1078))) (list (quote apply) (list (quote lambda) syntmp-new-vars-1081 (syntmp-chi-103 syntmp-exp-1075 (syntmp-extend-env-61 syntmp-labels-1080 (map (lambda (syntmp-var-1082 syntmp-level-1083) (cons (quote syntax) (cons syntmp-var-1082 syntmp-level-1083))) syntmp-new-vars-1081 (map cdr syntmp-pvars-1074)) syntmp-r-1077) (syntmp-make-binding-wrap-84 syntmp-ids-1078 syntmp-labels-1080 (quote (()))))) syntmp-y-1076))))) (syntmp-convert-pattern-1039 (lambda (syntmp-pattern-1084 syntmp-keys-1085) (let syntmp-cvt-1086 ((syntmp-p-1087 syntmp-pattern-1084) (syntmp-n-1088 (quote 0)) (syntmp-ids-1089 (quote ()))) (if (syntmp-id?-67 syntmp-p-1087) (if (syntmp-bound-id-member?-94 syntmp-p-1087 syntmp-keys-1085) (values (vector (quote free-id) syntmp-p-1087) syntmp-ids-1089) (values (quote any) (cons (cons syntmp-p-1087 syntmp-n-1088) syntmp-ids-1089))) ((lambda (syntmp-tmp-1090) ((lambda (syntmp-tmp-1091) (if (if syntmp-tmp-1091 (apply (lambda (syntmp-x-1092 syntmp-dots-1093) (syntmp-ellipsis?-112 syntmp-dots-1093)) syntmp-tmp-1091) (quote #f)) (apply (lambda (syntmp-x-1094 syntmp-dots-1095) (call-with-values (lambda () (syntmp-cvt-1086 syntmp-x-1094 (syntmp-fx+-38 syntmp-n-1088 (quote 1)) syntmp-ids-1089)) (lambda (syntmp-p-1096 syntmp-ids-1097) (values (if (eq? syntmp-p-1096 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1096)) syntmp-ids-1097)))) syntmp-tmp-1091) ((lambda (syntmp-tmp-1098) (if syntmp-tmp-1098 (apply (lambda (syntmp-x-1099 syntmp-y-1100) (call-with-values (lambda () (syntmp-cvt-1086 syntmp-y-1100 syntmp-n-1088 syntmp-ids-1089)) (lambda (syntmp-y-1101 syntmp-ids-1102) (call-with-values (lambda () (syntmp-cvt-1086 syntmp-x-1099 syntmp-n-1088 syntmp-ids-1102)) (lambda (syntmp-x-1103 syntmp-ids-1104) (values (cons syntmp-x-1103 syntmp-y-1101) syntmp-ids-1104)))))) syntmp-tmp-1098) ((lambda (syntmp-tmp-1105) (if syntmp-tmp-1105 (apply (lambda () (values (quote ()) syntmp-ids-1089)) syntmp-tmp-1105) ((lambda (syntmp-tmp-1106) (if syntmp-tmp-1106 (apply (lambda (syntmp-x-1107) (call-with-values (lambda () (syntmp-cvt-1086 syntmp-x-1107 syntmp-n-1088 syntmp-ids-1089)) (lambda (syntmp-p-1109 syntmp-ids-1110) (values (vector (quote vector) syntmp-p-1109) syntmp-ids-1110)))) syntmp-tmp-1106) ((lambda (syntmp-x-1111) (values (vector (quote atom) (syntmp-strip-114 syntmp-p-1087 (quote (())))) syntmp-ids-1089)) syntmp-tmp-1090))) (syntax-dispatch syntmp-tmp-1090 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1090 (quote ()))))) (syntax-dispatch syntmp-tmp-1090 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1090 (quote (any any))))) syntmp-p-1087)))))) (lambda (syntmp-e-1112 syntmp-r-1113 syntmp-w-1114 syntmp-s-1115) (let ((syntmp-e-1116 (syntmp-source-wrap-96 syntmp-e-1112 syntmp-w-1114 syntmp-s-1115))) ((lambda (syntmp-tmp-1117) ((lambda (syntmp-tmp-1118) (if syntmp-tmp-1118 (apply (lambda (syntmp-_-1119 syntmp-val-1120 syntmp-key-1121 syntmp-m-1122) (if (andmap (lambda (syntmp-x-1123) (and (syntmp-id?-67 syntmp-x-1123) (not (syntmp-ellipsis?-112 syntmp-x-1123)))) syntmp-key-1121) (let ((syntmp-x-1125 (syntmp-gen-var-115 (quote tmp)))) (list (list (quote lambda) (list syntmp-x-1125) (syntmp-gen-syntax-case-1042 syntmp-x-1125 syntmp-key-1121 syntmp-m-1122 syntmp-r-1113)) (syntmp-chi-103 syntmp-val-1120 syntmp-r-1113 (quote (()))))) (syntax-error syntmp-e-1116 (quote "invalid literals list in")))) syntmp-tmp-1118) (syntax-error syntmp-tmp-1117))) (syntax-dispatch syntmp-tmp-1117 (quote (any any each-any . each-any))))) syntmp-e-1116))))) (set! sc-expand (let ((syntmp-m-1128 (quote e)) (syntmp-esew-1129 (quote (eval)))) (lambda (syntmp-x-1130) (if (and (pair? syntmp-x-1130) (equal? (car syntmp-x-1130) syntmp-noexpand-37)) (cadr syntmp-x-1130) (syntmp-chi-top-102 syntmp-x-1130 (quote ()) (quote ((top))) syntmp-m-1128 syntmp-esew-1129))))) (set! sc-expand3 (let ((syntmp-m-1131 (quote e)) (syntmp-esew-1132 (quote (eval)))) (lambda (syntmp-x-1134 . syntmp-rest-1133) (if (and (pair? syntmp-x-1134) (equal? (car syntmp-x-1134) syntmp-noexpand-37)) (cadr syntmp-x-1134) (syntmp-chi-top-102 syntmp-x-1134 (quote ()) (quote ((top))) (if (null? syntmp-rest-1133) syntmp-m-1131 (car syntmp-rest-1133)) (if (or (null? syntmp-rest-1133) (null? (cdr syntmp-rest-1133))) syntmp-esew-1132 (cadr syntmp-rest-1133))))))) (set! identifier? (lambda (syntmp-x-1135) (syntmp-nonsymbol-id?-66 syntmp-x-1135))) (set! datum->syntax-object (lambda (syntmp-id-1136 syntmp-datum-1137) (syntmp-make-syntax-object-52 syntmp-datum-1137 (syntmp-syntax-object-wrap-55 syntmp-id-1136)))) (set! syntax-object->datum (lambda (syntmp-x-1138) (syntmp-strip-114 syntmp-x-1138 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1139) (begin (let ((syntmp-x-1140 syntmp-ls-1139)) (if (not (list? syntmp-x-1140)) (syntmp-error-hook-45 (quote generate-temporaries) (quote "invalid argument") syntmp-x-1140))) (map (lambda (syntmp-x-1141) (syntmp-wrap-95 (gensym) (quote ((top))))) syntmp-ls-1139)))) (set! free-identifier=? (lambda (syntmp-x-1142 syntmp-y-1143) (begin (let ((syntmp-x-1144 syntmp-x-1142)) (if (not (syntmp-nonsymbol-id?-66 syntmp-x-1144)) (syntmp-error-hook-45 (quote free-identifier=?) (quote "invalid argument") syntmp-x-1144))) (let ((syntmp-x-1145 syntmp-y-1143)) (if (not (syntmp-nonsymbol-id?-66 syntmp-x-1145)) (syntmp-error-hook-45 (quote free-identifier=?) (quote "invalid argument") syntmp-x-1145))) (syntmp-free-id=?-90 syntmp-x-1142 syntmp-y-1143)))) (set! bound-identifier=? (lambda (syntmp-x-1146 syntmp-y-1147) (begin (let ((syntmp-x-1148 syntmp-x-1146)) (if (not (syntmp-nonsymbol-id?-66 syntmp-x-1148)) (syntmp-error-hook-45 (quote bound-identifier=?) (quote "invalid argument") syntmp-x-1148))) (let ((syntmp-x-1149 syntmp-y-1147)) (if (not (syntmp-nonsymbol-id?-66 syntmp-x-1149)) (syntmp-error-hook-45 (quote bound-identifier=?) (quote "invalid argument") syntmp-x-1149))) (syntmp-bound-id=?-91 syntmp-x-1146 syntmp-y-1147)))) (set! syntax-error (lambda (syntmp-object-1151 . syntmp-messages-1150) (begin (for-each (lambda (syntmp-x-1152) (let ((syntmp-x-1153 syntmp-x-1152)) (if (not (string? syntmp-x-1153)) (syntmp-error-hook-45 (quote syntax-error) (quote "invalid argument") syntmp-x-1153)))) syntmp-messages-1150) (let ((syntmp-message-1154 (if (null? syntmp-messages-1150) (quote "invalid syntax") (apply string-append syntmp-messages-1150)))) (syntmp-error-hook-45 (quote #f) syntmp-message-1154 (syntmp-strip-114 syntmp-object-1151 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1155 syntmp-v-1156) (begin (let ((syntmp-x-1157 syntmp-sym-1155)) (if (not (symbol? syntmp-x-1157)) (syntmp-error-hook-45 (quote define-syntax) (quote "invalid argument") syntmp-x-1157))) (let ((syntmp-x-1158 syntmp-v-1156)) (if (not (procedure? syntmp-x-1158)) (syntmp-error-hook-45 (quote define-syntax) (quote "invalid argument") syntmp-x-1158))) (syntmp-global-extend-65 (quote macro) syntmp-sym-1155 syntmp-v-1156)))) (letrec ((syntmp-match-1163 (lambda (syntmp-e-1164 syntmp-p-1165 syntmp-w-1166 syntmp-r-1167) (cond ((not syntmp-r-1167) (quote #f)) ((eq? syntmp-p-1165 (quote any)) (cons (syntmp-wrap-95 syntmp-e-1164 syntmp-w-1166) syntmp-r-1167)) ((syntmp-syntax-object?-53 syntmp-e-1164) (syntmp-match*-1162 (let ((syntmp-e-1168 (syntmp-syntax-object-expression-54 syntmp-e-1164))) (if (syntmp-annotation?-42 syntmp-e-1168) (annotation-expression syntmp-e-1168) syntmp-e-1168)) syntmp-p-1165 (syntmp-join-wraps-86 syntmp-w-1166 (syntmp-syntax-object-wrap-55 syntmp-e-1164)) syntmp-r-1167)) (else (syntmp-match*-1162 (let ((syntmp-e-1169 syntmp-e-1164)) (if (syntmp-annotation?-42 syntmp-e-1169) (annotation-expression syntmp-e-1169) syntmp-e-1169)) syntmp-p-1165 syntmp-w-1166 syntmp-r-1167))))) (syntmp-match*-1162 (lambda (syntmp-e-1170 syntmp-p-1171 syntmp-w-1172 syntmp-r-1173) (cond ((null? syntmp-p-1171) (and (null? syntmp-e-1170) syntmp-r-1173)) ((pair? syntmp-p-1171) (and (pair? syntmp-e-1170) (syntmp-match-1163 (car syntmp-e-1170) (car syntmp-p-1171) syntmp-w-1172 (syntmp-match-1163 (cdr syntmp-e-1170) (cdr syntmp-p-1171) syntmp-w-1172 syntmp-r-1173)))) ((eq? syntmp-p-1171 (quote each-any)) (let ((syntmp-l-1174 (syntmp-match-each-any-1160 syntmp-e-1170 syntmp-w-1172))) (and syntmp-l-1174 (cons syntmp-l-1174 syntmp-r-1173)))) (else (let ((syntmp-t-1175 (vector-ref syntmp-p-1171 (quote 0)))) (if (memv syntmp-t-1175 (quote (each))) (if (null? syntmp-e-1170) (syntmp-match-empty-1161 (vector-ref syntmp-p-1171 (quote 1)) syntmp-r-1173) (let ((syntmp-l-1176 (syntmp-match-each-1159 syntmp-e-1170 (vector-ref syntmp-p-1171 (quote 1)) syntmp-w-1172))) (and syntmp-l-1176 (let syntmp-collect-1177 ((syntmp-l-1178 syntmp-l-1176)) (if (null? (car syntmp-l-1178)) syntmp-r-1173 (cons (map car syntmp-l-1178) (syntmp-collect-1177 (map cdr syntmp-l-1178)))))))) (if (memv syntmp-t-1175 (quote (free-id))) (and (syntmp-id?-67 syntmp-e-1170) (syntmp-free-id=?-90 (syntmp-wrap-95 syntmp-e-1170 syntmp-w-1172) (vector-ref syntmp-p-1171 (quote 1))) syntmp-r-1173) (if (memv syntmp-t-1175 (quote (atom))) (and (equal? (vector-ref syntmp-p-1171 (quote 1)) (syntmp-strip-114 syntmp-e-1170 syntmp-w-1172)) syntmp-r-1173) (if (memv syntmp-t-1175 (quote (vector))) (and (vector? syntmp-e-1170) (syntmp-match-1163 (vector->list syntmp-e-1170) (vector-ref syntmp-p-1171 (quote 1)) syntmp-w-1172 syntmp-r-1173))))))))))) (syntmp-match-empty-1161 (lambda (syntmp-p-1179 syntmp-r-1180) (cond ((null? syntmp-p-1179) syntmp-r-1180) ((eq? syntmp-p-1179 (quote any)) (cons (quote ()) syntmp-r-1180)) ((pair? syntmp-p-1179) (syntmp-match-empty-1161 (car syntmp-p-1179) (syntmp-match-empty-1161 (cdr syntmp-p-1179) syntmp-r-1180))) ((eq? syntmp-p-1179 (quote each-any)) (cons (quote ()) syntmp-r-1180)) (else (let ((syntmp-t-1181 (vector-ref syntmp-p-1179 (quote 0)))) (if (memv syntmp-t-1181 (quote (each))) (syntmp-match-empty-1161 (vector-ref syntmp-p-1179 (quote 1)) syntmp-r-1180) (if (memv syntmp-t-1181 (quote (free-id atom))) syntmp-r-1180 (if (memv syntmp-t-1181 (quote (vector))) (syntmp-match-empty-1161 (vector-ref syntmp-p-1179 (quote 1)) syntmp-r-1180))))))))) (syntmp-match-each-any-1160 (lambda (syntmp-e-1182 syntmp-w-1183) (cond ((syntmp-annotation?-42 syntmp-e-1182) (syntmp-match-each-any-1160 (annotation-expression syntmp-e-1182) syntmp-w-1183)) ((pair? syntmp-e-1182) (let ((syntmp-l-1184 (syntmp-match-each-any-1160 (cdr syntmp-e-1182) syntmp-w-1183))) (and syntmp-l-1184 (cons (syntmp-wrap-95 (car syntmp-e-1182) syntmp-w-1183) syntmp-l-1184)))) ((null? syntmp-e-1182) (quote ())) ((syntmp-syntax-object?-53 syntmp-e-1182) (syntmp-match-each-any-1160 (syntmp-syntax-object-expression-54 syntmp-e-1182) (syntmp-join-wraps-86 syntmp-w-1183 (syntmp-syntax-object-wrap-55 syntmp-e-1182)))) (else (quote #f))))) (syntmp-match-each-1159 (lambda (syntmp-e-1185 syntmp-p-1186 syntmp-w-1187) (cond ((syntmp-annotation?-42 syntmp-e-1185) (syntmp-match-each-1159 (annotation-expression syntmp-e-1185) syntmp-p-1186 syntmp-w-1187)) ((pair? syntmp-e-1185) (let ((syntmp-first-1188 (syntmp-match-1163 (car syntmp-e-1185) syntmp-p-1186 syntmp-w-1187 (quote ())))) (and syntmp-first-1188 (let ((syntmp-rest-1189 (syntmp-match-each-1159 (cdr syntmp-e-1185) syntmp-p-1186 syntmp-w-1187))) (and syntmp-rest-1189 (cons syntmp-first-1188 syntmp-rest-1189)))))) ((null? syntmp-e-1185) (quote ())) ((syntmp-syntax-object?-53 syntmp-e-1185) (syntmp-match-each-1159 (syntmp-syntax-object-expression-54 syntmp-e-1185) syntmp-p-1186 (syntmp-join-wraps-86 syntmp-w-1187 (syntmp-syntax-object-wrap-55 syntmp-e-1185)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (syntmp-e-1190 syntmp-p-1191) (cond ((eq? syntmp-p-1191 (quote any)) (list syntmp-e-1190)) ((syntmp-syntax-object?-53 syntmp-e-1190) (syntmp-match*-1162 (let ((syntmp-e-1192 (syntmp-syntax-object-expression-54 syntmp-e-1190))) (if (syntmp-annotation?-42 syntmp-e-1192) (annotation-expression syntmp-e-1192) syntmp-e-1192)) syntmp-p-1191 (syntmp-syntax-object-wrap-55 syntmp-e-1190) (quote ()))) (else (syntmp-match*-1162 (let ((syntmp-e-1193 syntmp-e-1190)) (if (syntmp-annotation?-42 syntmp-e-1193) (annotation-expression syntmp-e-1193) syntmp-e-1193)) syntmp-p-1191 (quote (())) (quote ()))))))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1194) ((lambda (syntmp-tmp-1195) ((lambda (syntmp-tmp-1196) (if syntmp-tmp-1196 (apply (lambda (syntmp-_-1197 syntmp-e1-1198 syntmp-e2-1199) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1198 syntmp-e2-1199))) syntmp-tmp-1196) ((lambda (syntmp-tmp-1201) (if syntmp-tmp-1201 (apply (lambda (syntmp-_-1202 syntmp-out-1203 syntmp-in-1204 syntmp-e1-1205 syntmp-e2-1206) (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"))))) syntmp-in-1204 (quote ()) (list syntmp-out-1203 (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"))))) (cons syntmp-e1-1205 syntmp-e2-1206))))) syntmp-tmp-1201) ((lambda (syntmp-tmp-1208) (if syntmp-tmp-1208 (apply (lambda (syntmp-_-1209 syntmp-out-1210 syntmp-in-1211 syntmp-e1-1212 syntmp-e2-1213) (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"))))) (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"))))) syntmp-in-1211) (quote ()) (list syntmp-out-1210 (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"))))) (cons syntmp-e1-1212 syntmp-e2-1213))))) syntmp-tmp-1208) (syntax-error syntmp-tmp-1195))) (syntax-dispatch syntmp-tmp-1195 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1195 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1195 (quote (any () any . each-any))))) syntmp-x-1194))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1217) ((lambda (syntmp-tmp-1218) ((lambda (syntmp-tmp-1219) (if syntmp-tmp-1219 (apply (lambda (syntmp-_-1220 syntmp-k-1221 syntmp-keyword-1222 syntmp-pattern-1223 syntmp-template-1224) (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"))))) (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")))))) (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"))))) (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"))))) (cons syntmp-k-1221 (map (lambda (syntmp-tmp-1227 syntmp-tmp-1226) (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"))))) syntmp-tmp-1226) (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"))))) syntmp-tmp-1227))) syntmp-template-1224 syntmp-pattern-1223)))))) syntmp-tmp-1219) (syntax-error syntmp-tmp-1218))) (syntax-dispatch syntmp-tmp-1218 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1217))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1228) ((lambda (syntmp-tmp-1229) ((lambda (syntmp-tmp-1230) (if (if syntmp-tmp-1230 (apply (lambda (syntmp-let*-1231 syntmp-x-1232 syntmp-v-1233 syntmp-e1-1234 syntmp-e2-1235) (andmap identifier? syntmp-x-1232)) syntmp-tmp-1230) (quote #f)) (apply (lambda (syntmp-let*-1237 syntmp-x-1238 syntmp-v-1239 syntmp-e1-1240 syntmp-e2-1241) (let syntmp-f-1242 ((syntmp-bindings-1243 (map list syntmp-x-1238 syntmp-v-1239))) (if (null? syntmp-bindings-1243) (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"))))) (cons (quote ()) (cons syntmp-e1-1240 syntmp-e2-1241))) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if syntmp-tmp-1248 (apply (lambda (syntmp-body-1249 syntmp-binding-1250) (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"))))) (list syntmp-binding-1250) syntmp-body-1249)) syntmp-tmp-1248) (syntax-error syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any any))))) (list (syntmp-f-1242 (cdr syntmp-bindings-1243)) (car syntmp-bindings-1243)))))) syntmp-tmp-1230) (syntax-error syntmp-tmp-1229))) (syntax-dispatch syntmp-tmp-1229 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1228))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1251) ((lambda (syntmp-tmp-1252) ((lambda (syntmp-tmp-1253) (if syntmp-tmp-1253 (apply (lambda (syntmp-_-1254 syntmp-var-1255 syntmp-init-1256 syntmp-step-1257 syntmp-e0-1258 syntmp-e1-1259 syntmp-c-1260) ((lambda (syntmp-tmp-1261) ((lambda (syntmp-tmp-1262) (if syntmp-tmp-1262 (apply (lambda (syntmp-step-1263) ((lambda (syntmp-tmp-1264) ((lambda (syntmp-tmp-1265) (if syntmp-tmp-1265 (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"))))) (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"))))) (map list syntmp-var-1255 syntmp-init-1256) (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"))))) (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"))))) syntmp-e0-1258) (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"))))) (append syntmp-c-1260 (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"))))) syntmp-step-1263))))))) syntmp-tmp-1265) ((lambda (syntmp-tmp-1270) (if syntmp-tmp-1270 (apply (lambda (syntmp-e1-1271 syntmp-e2-1272) (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"))))) (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"))))) (map list syntmp-var-1255 syntmp-init-1256) (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"))))) syntmp-e0-1258 (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"))))) (cons syntmp-e1-1271 syntmp-e2-1272)) (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"))))) (append syntmp-c-1260 (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"))))) syntmp-step-1263))))))) syntmp-tmp-1270) (syntax-error syntmp-tmp-1264))) (syntax-dispatch syntmp-tmp-1264 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1264 (quote ())))) syntmp-e1-1259)) syntmp-tmp-1262) (syntax-error syntmp-tmp-1261))) (syntax-dispatch syntmp-tmp-1261 (quote each-any)))) (map (lambda (syntmp-v-1279 syntmp-s-1280) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda () syntmp-v-1279) syntmp-tmp-1282) ((lambda (syntmp-tmp-1283) (if syntmp-tmp-1283 (apply (lambda (syntmp-e-1284) syntmp-e-1284) syntmp-tmp-1283) ((lambda (syntmp-_-1285) (syntax-error syntmp-orig-x-1251)) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any)))))) (syntax-dispatch syntmp-tmp-1281 (quote ())))) syntmp-s-1280)) syntmp-var-1255 syntmp-step-1257))) syntmp-tmp-1253) (syntax-error syntmp-tmp-1252))) (syntax-dispatch syntmp-tmp-1252 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1251))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1288 (lambda (syntmp-x-1292 syntmp-y-1293) ((lambda (syntmp-tmp-1294) ((lambda (syntmp-tmp-1295) (if syntmp-tmp-1295 (apply (lambda (syntmp-x-1296 syntmp-y-1297) ((lambda (syntmp-tmp-1298) ((lambda (syntmp-tmp-1299) (if syntmp-tmp-1299 (apply (lambda (syntmp-dy-1300) ((lambda (syntmp-tmp-1301) ((lambda (syntmp-tmp-1302) (if syntmp-tmp-1302 (apply (lambda (syntmp-dx-1303) (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"))))) (cons syntmp-dx-1303 syntmp-dy-1300))) syntmp-tmp-1302) ((lambda (syntmp-_-1304) (if (null? syntmp-dy-1300) (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"))))) syntmp-x-1296) (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"))))) syntmp-x-1296 syntmp-y-1297))) syntmp-tmp-1301))) (syntax-dispatch syntmp-tmp-1301 (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"))))) any))))) syntmp-x-1296)) syntmp-tmp-1299) ((lambda (syntmp-tmp-1305) (if syntmp-tmp-1305 (apply (lambda (syntmp-stuff-1306) (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"))))) (cons syntmp-x-1296 syntmp-stuff-1306))) syntmp-tmp-1305) ((lambda (syntmp-else-1307) (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"))))) syntmp-x-1296 syntmp-y-1297)) syntmp-tmp-1298))) (syntax-dispatch syntmp-tmp-1298 (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"))))) . any)))))) (syntax-dispatch syntmp-tmp-1298 (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"))))) any))))) syntmp-y-1297)) syntmp-tmp-1295) (syntax-error syntmp-tmp-1294))) (syntax-dispatch syntmp-tmp-1294 (quote (any any))))) (list syntmp-x-1292 syntmp-y-1293)))) (syntmp-quasiappend-1289 (lambda (syntmp-x-1308 syntmp-y-1309) ((lambda (syntmp-tmp-1310) ((lambda (syntmp-tmp-1311) (if syntmp-tmp-1311 (apply (lambda (syntmp-x-1312 syntmp-y-1313) ((lambda (syntmp-tmp-1314) ((lambda (syntmp-tmp-1315) (if syntmp-tmp-1315 (apply (lambda () syntmp-x-1312) syntmp-tmp-1315) ((lambda (syntmp-_-1316) (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"))))) syntmp-x-1312 syntmp-y-1313)) syntmp-tmp-1314))) (syntax-dispatch syntmp-tmp-1314 (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"))))) ()))))) syntmp-y-1313)) syntmp-tmp-1311) (syntax-error syntmp-tmp-1310))) (syntax-dispatch syntmp-tmp-1310 (quote (any any))))) (list syntmp-x-1308 syntmp-y-1309)))) (syntmp-quasivector-1290 (lambda (syntmp-x-1317) ((lambda (syntmp-tmp-1318) ((lambda (syntmp-x-1319) ((lambda (syntmp-tmp-1320) ((lambda (syntmp-tmp-1321) (if syntmp-tmp-1321 (apply (lambda (syntmp-x-1322) (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"))))) (list->vector syntmp-x-1322))) syntmp-tmp-1321) ((lambda (syntmp-tmp-1324) (if syntmp-tmp-1324 (apply (lambda (syntmp-x-1325) (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"))))) syntmp-x-1325)) syntmp-tmp-1324) ((lambda (syntmp-_-1327) (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"))))) syntmp-x-1319)) syntmp-tmp-1320))) (syntax-dispatch syntmp-tmp-1320 (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"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1320 (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"))))) each-any))))) syntmp-x-1319)) syntmp-tmp-1318)) syntmp-x-1317))) (syntmp-quasi-1291 (lambda (syntmp-p-1328 syntmp-lev-1329) ((lambda (syntmp-tmp-1330) ((lambda (syntmp-tmp-1331) (if syntmp-tmp-1331 (apply (lambda (syntmp-p-1332) (if (= syntmp-lev-1329 (quote 0)) syntmp-p-1332 (syntmp-quasicons-1288 (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")))) #(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")))))) (syntmp-quasi-1291 (list syntmp-p-1332) (- syntmp-lev-1329 (quote 1)))))) syntmp-tmp-1331) ((lambda (syntmp-tmp-1333) (if syntmp-tmp-1333 (apply (lambda (syntmp-p-1334 syntmp-q-1335) (if (= syntmp-lev-1329 (quote 0)) (syntmp-quasiappend-1289 syntmp-p-1334 (syntmp-quasi-1291 syntmp-q-1335 syntmp-lev-1329)) (syntmp-quasicons-1288 (syntmp-quasicons-1288 (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")))) #(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")))))) (syntmp-quasi-1291 (list syntmp-p-1334) (- syntmp-lev-1329 (quote 1)))) (syntmp-quasi-1291 syntmp-q-1335 syntmp-lev-1329)))) syntmp-tmp-1333) ((lambda (syntmp-tmp-1336) (if syntmp-tmp-1336 (apply (lambda (syntmp-p-1337) (syntmp-quasicons-1288 (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")))) #(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")))))) (syntmp-quasi-1291 (list syntmp-p-1337) (+ syntmp-lev-1329 (quote 1))))) syntmp-tmp-1336) ((lambda (syntmp-tmp-1338) (if syntmp-tmp-1338 (apply (lambda (syntmp-p-1339 syntmp-q-1340) (syntmp-quasicons-1288 (syntmp-quasi-1291 syntmp-p-1339 syntmp-lev-1329) (syntmp-quasi-1291 syntmp-q-1340 syntmp-lev-1329))) syntmp-tmp-1338) ((lambda (syntmp-tmp-1341) (if syntmp-tmp-1341 (apply (lambda (syntmp-x-1342) (syntmp-quasivector-1290 (syntmp-quasi-1291 syntmp-x-1342 syntmp-lev-1329))) syntmp-tmp-1341) ((lambda (syntmp-p-1344) (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"))))) syntmp-p-1344)) syntmp-tmp-1330))) (syntax-dispatch syntmp-tmp-1330 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1330 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1330 (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"))))) any)))))) (syntax-dispatch syntmp-tmp-1330 (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"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1330 (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"))))) any))))) syntmp-p-1328)))) (lambda (syntmp-x-1345) ((lambda (syntmp-tmp-1346) ((lambda (syntmp-tmp-1347) (if syntmp-tmp-1347 (apply (lambda (syntmp-_-1348 syntmp-e-1349) (syntmp-quasi-1291 syntmp-e-1349 (quote 0))) syntmp-tmp-1347) (syntax-error syntmp-tmp-1346))) (syntax-dispatch syntmp-tmp-1346 (quote (any any))))) syntmp-x-1345)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1350) (letrec ((syntmp-read-file-1351 (lambda (syntmp-fn-1352 syntmp-k-1353) (let ((syntmp-p-1354 (open-input-file syntmp-fn-1352))) (let syntmp-f-1355 ((syntmp-x-1356 (read syntmp-p-1354))) (if (eof-object? syntmp-x-1356) (begin (close-input-port syntmp-p-1354) (quote ())) (cons (datum->syntax-object syntmp-k-1353 syntmp-x-1356) (syntmp-f-1355 (read syntmp-p-1354))))))))) ((lambda (syntmp-tmp-1357) ((lambda (syntmp-tmp-1358) (if syntmp-tmp-1358 (apply (lambda (syntmp-k-1359 syntmp-filename-1360) (let ((syntmp-fn-1361 (syntax-object->datum syntmp-filename-1360))) ((lambda (syntmp-tmp-1362) ((lambda (syntmp-tmp-1363) (if syntmp-tmp-1363 (apply (lambda (syntmp-exp-1364) (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"))))) syntmp-exp-1364)) syntmp-tmp-1363) (syntax-error syntmp-tmp-1362))) (syntax-dispatch syntmp-tmp-1362 (quote each-any)))) (syntmp-read-file-1351 syntmp-fn-1361 syntmp-k-1359)))) syntmp-tmp-1358) (syntax-error syntmp-tmp-1357))) (syntax-dispatch syntmp-tmp-1357 (quote (any any))))) syntmp-x-1350)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1366) ((lambda (syntmp-tmp-1367) ((lambda (syntmp-tmp-1368) (if syntmp-tmp-1368 (apply (lambda (syntmp-_-1369 syntmp-e-1370) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum syntmp-e-1370))) syntmp-tmp-1368) (syntax-error syntmp-tmp-1367))) (syntax-dispatch syntmp-tmp-1367 (quote (any any))))) syntmp-x-1366))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1371) ((lambda (syntmp-tmp-1372) ((lambda (syntmp-tmp-1373) (if syntmp-tmp-1373 (apply (lambda (syntmp-_-1374 syntmp-e-1375) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum syntmp-e-1375))) syntmp-tmp-1373) (syntax-error syntmp-tmp-1372))) (syntax-dispatch syntmp-tmp-1372 (quote (any any))))) syntmp-x-1371))) +(install-global-transformer (quote case) (lambda (syntmp-x-1376) ((lambda (syntmp-tmp-1377) ((lambda (syntmp-tmp-1378) (if syntmp-tmp-1378 (apply (lambda (syntmp-_-1379 syntmp-e-1380 syntmp-m1-1381 syntmp-m2-1382) ((lambda (syntmp-tmp-1383) ((lambda (syntmp-body-1384) (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"))))) (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"))))) syntmp-e-1380)) syntmp-body-1384)) syntmp-tmp-1383)) (let syntmp-f-1385 ((syntmp-clause-1386 syntmp-m1-1381) (syntmp-clauses-1387 syntmp-m2-1382)) (if (null? syntmp-clauses-1387) ((lambda (syntmp-tmp-1389) ((lambda (syntmp-tmp-1390) (if syntmp-tmp-1390 (apply (lambda (syntmp-e1-1391 syntmp-e2-1392) (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"))))) (cons syntmp-e1-1391 syntmp-e2-1392))) syntmp-tmp-1390) ((lambda (syntmp-tmp-1394) (if syntmp-tmp-1394 (apply (lambda (syntmp-k-1395 syntmp-e1-1396 syntmp-e2-1397) (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"))))) (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"))))) (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"))))) (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"))))) syntmp-k-1395)) (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"))))) (cons syntmp-e1-1396 syntmp-e2-1397)))) syntmp-tmp-1394) ((lambda (syntmp-_-1400) (syntax-error syntmp-x-1376)) syntmp-tmp-1389))) (syntax-dispatch syntmp-tmp-1389 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1389 (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"))))) any . each-any))))) syntmp-clause-1386) ((lambda (syntmp-tmp-1401) ((lambda (syntmp-rest-1402) ((lambda (syntmp-tmp-1403) ((lambda (syntmp-tmp-1404) (if syntmp-tmp-1404 (apply (lambda (syntmp-k-1405 syntmp-e1-1406 syntmp-e2-1407) (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"))))) (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"))))) (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"))))) (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"))))) syntmp-k-1405)) (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"))))) (cons syntmp-e1-1406 syntmp-e2-1407)) syntmp-rest-1402)) syntmp-tmp-1404) ((lambda (syntmp-_-1410) (syntax-error syntmp-x-1376)) syntmp-tmp-1403))) (syntax-dispatch syntmp-tmp-1403 (quote (each-any any . each-any))))) syntmp-clause-1386)) syntmp-tmp-1401)) (syntmp-f-1385 (car syntmp-clauses-1387) (cdr syntmp-clauses-1387))))))) syntmp-tmp-1378) (syntax-error syntmp-tmp-1377))) (syntax-dispatch syntmp-tmp-1377 (quote (any any any . each-any))))) syntmp-x-1376))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1411) ((lambda (syntmp-tmp-1412) ((lambda (syntmp-tmp-1413) (if syntmp-tmp-1413 (apply (lambda (syntmp-_-1414 syntmp-e-1415) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1415)) (list (cons syntmp-_-1414 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1415 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1413) (syntax-error syntmp-tmp-1412))) (syntax-dispatch syntmp-tmp-1412 (quote (any any))))) syntmp-x-1411))) From 51a317b3b0bee2c411b68da36da39264b4b18ffa Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 05:49:05 +0000 Subject: [PATCH 66/81] * syncase.scm (gensym): redefine locally so we can control it's properties. This is in preparation for changing the future public gensym to produce unreadable symbols. --- ice-9/syncase.scm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/ice-9/syncase.scm b/ice-9/syncase.scm index 36ea4f962..dc8c321c7 100644 --- a/ice-9/syncase.scm +++ b/ice-9/syncase.scm @@ -149,6 +149,29 @@ (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)) + (lambda (. rest) + (let ((val (number->string counter))) + (set! counter (+ counter 1)) + (cond + ((null? rest) + (string->symbol (string-append "syntmp-" val))) + ((null? (cdr rest)) + (string->symbol (string-append "syntmp-" (car rest) "-" val))) + (else + (error + "syncase's gensym called with the wrong number of arguments"))))))) + ;;; Load the preprocessed code (let ((old-debug #f) From 5198619b6cb6224361cc8585778c9bd848ca4654 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 05:49:23 +0000 Subject: [PATCH 67/81] * .cvsignore: add stamp-h1. --- libguile/.cvsignore | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/libguile/.cvsignore b/libguile/.cvsignore index 6f57459a2..45a60e238 100644 --- a/libguile/.cvsignore +++ b/libguile/.cvsignore @@ -1,16 +1,17 @@ -.cvsignore +*.bb +*.bbg +*.da *.doc +*.gcov *.la *.lo *.x -*.bb -*.bbg -*.gcov -*.da +.cvsignore .deps .libs Makefile Makefile.in +c-tokenize.c config.cache config.log config.status @@ -23,18 +24,19 @@ gh_test_repl guile guile-doc-snarf guile-func-name-check +guile-procedures.texi guile-procedures.txt guile-snarf guile-snarf-docs guile-snarf-docs-texi guile-snarf.awk -guile_filter_doc_snarfage guile.texi +guile_filter_doc_snarfage libpath.h libtool scmconfig.h scmconfig.h.in stamp-h stamp-h.in +stamp-h1 version.h -c-tokenize.c From 22b7f585108cacf2d0f1ca1e7b4d9f0644e8ba59 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 05:50:10 +0000 Subject: [PATCH 68/81] * configure.in: AC_SUBST the centralized shared lib versioning variables from ./GUILE-VERSION. (LIBQTHREADS_INTERFACE_CURRENT): new AC_SUBST. (LIBQTHREADS_INTERFACE_REVISION): new AC_SUBST. (LIBQTHREADS_INTERFACE_AGE): new AC_SUBST. (LIBQTHREADS_INTERFACE): new AC_SUBST. (LIBGUILE_INTERFACE_CURRENT): new AC_SUBST. (LIBGUILE_INTERFACE_REVISION): new AC_SUBST. (LIBGUILE_INTERFACE_AGE): new AC_SUBST. (LIBGUILE_INTERFACE): new AC_SUBST. (LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT): new AC_SUBST. (LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION): new AC_SUBST. (LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE): new AC_SUBST. (LIBGUILE_SRFI_SRFI_4_INTERFACE): new AC_SUBST. (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT): new AC_SUBST. (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION): new AC_SUBST. (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE): new AC_SUBST. (LIBGUILE_SRFI_SRFI_13_14_INTERFACE): new AC_SUBST. --- configure.in | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/configure.in b/configure.in index ca9971ffb..671b490ed 100644 --- a/configure.in +++ b/configure.in @@ -617,10 +617,6 @@ if test "${THREAD_PACKAGE}" != "" ; then AC_CHECK_LIB(pthread, main) fi fi -AC_SUBST(LIBGUILEQTHREADS_INTERFACE_CURRENT) -AC_SUBST(LIBGUILEQTHREADS_INTERFACE_REVISION) -AC_SUBST(LIBGUILEQTHREADS_INTERFACE_AGE) -AC_SUBST(LIBGUILEQTHREADS_INTERFACE) ## If we're using GCC, ask for aggressive warnings. case "$GCC" in @@ -653,11 +649,31 @@ AC_SUBST(GUILE_MINOR_VERSION) AC_SUBST(GUILE_MICRO_VERSION) AC_SUBST(GUILE_VERSION) +####################################################################### +# library versioning + +AC_SUBST(LIBQTHREADS_INTERFACE_CURRENT) +AC_SUBST(LIBQTHREADS_INTERFACE_REVISION) +AC_SUBST(LIBQTHREADS_INTERFACE_AGE) +AC_SUBST(LIBQTHREADS_INTERFACE) + AC_SUBST(LIBGUILE_INTERFACE_CURRENT) AC_SUBST(LIBGUILE_INTERFACE_REVISION) AC_SUBST(LIBGUILE_INTERFACE_AGE) AC_SUBST(LIBGUILE_INTERFACE) +AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT) +AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION) +AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE) +AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE) + +AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT) +AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION) +AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE) +AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE) + +####################################################################### + dnl Tell guile-config what flags guile users should link against. GUILE_LIBS="$LDFLAGS $THREAD_LIBS_INSTALLED $LIBS" AC_SUBST(GUILE_LIBS) From 6040f80a5a312bffa356a842f65481640b466e1f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 05:50:48 +0000 Subject: [PATCH 69/81] * Makefile.am (libguile_srfi_srfi_4_la_LDFLAGS): use @LIBGUILE_SRFI_SRFI_4_INTERFACE@. (libguile_srfi_srfi_13_14_la_LDFLAGS): use @LIBGUILE_SRFI_SRFI_13_14_INTERFACE@. --- srfi/Makefile.am | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 38e6cf1a2..a23077a27 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -32,14 +32,17 @@ INCLUDES = -I.. -I$(srcdir)/.. lib_LTLIBRARIES = libguile-srfi-srfi-13-14.la libguile-srfi-srfi-4.la BUILT_SOURCES = srfi-13.x srfi-14.x srfi-4.x -libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c\ - srfi-13.h srfi-14.h -libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic -no-undefined -libguile_srfi_srfi_13_14_la_LIBADD = ../libguile/libguile.la libguile_srfi_srfi_4_la_SOURCES = srfi-4.x srfi-4.c srfi-4.h -libguile_srfi_srfi_4_la_LDFLAGS = -version-info 0:0 -export-dynamic -no-undefined libguile_srfi_srfi_4_la_LIBADD = ../libguile/libguile.la +libguile_srfi_srfi_4_la_LDFLAGS = -export-dynamic \ + -version-info @LIBGUILE_SRFI_SRFI_4_INTERFACE@ + +libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c\ + srfi-13.h srfi-14.h +libguile_srfi_srfi_13_14_la_LIBADD = ../libguile/libguile.la +libguile_srfi_srfi_13_14_la_LDFLAGS = -export-dynamic \ + -version-info @LIBGUILE_SRFI_SRFI_13_14_INTERFACE@ srfidir = $(datadir)/guile/$(VERSION)/srfi srfi_DATA = srfi-1.scm \ From c177f8dd57492e3502393b4850db8db1286a073f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 05:52:05 +0000 Subject: [PATCH 70/81] * Makefile.am (libqthreads_la_LDFLAGS): use @LIBQTHREADS_INTERFACE@. --- qt/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/qt/Makefile.am b/qt/Makefile.am index 4868a4a7f..b525cc1fe 100644 --- a/qt/Makefile.am +++ b/qt/Makefile.am @@ -34,7 +34,8 @@ INCLUDES = -I.. -I$(srcdir)/.. libqthreads_la_SOURCES = qt.c copyright.h libqthreads_la_LIBADD = qtmds.lo qtmdc.lo libqthreads_la_DEPENDENCIES = qtmds.lo qtmdc.lo -libqthreads_la_LDFLAGS = -rpath $(libdir) -version-info @LIBGUILEQTHREADS_INTERFACE_CURRENT@:@LIBGUILEQTHREADS_INTERFACE_REVISION@:@LIBGUILEQTHREADS_INTERFACE_AGE@ -export-dynamic -no-undefined +libqthreads_la_LDFLAGS = -rpath $(libdir) -export-dynamic -no-undefined \ + -version-info @LIBQTHREADS_INTERFACE@ # Seems to be obsolete - autogen.sh is giving: # invalid unused variable name: `OMIT_DEPENDENCIES' From 4615111283ce8859c138a2d4225d4f277d66e6d4 Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Mon, 25 Feb 2002 05:52:38 +0000 Subject: [PATCH 71/81] *** empty log message *** --- ChangeLog | 33 +++++++++++++++++++++++++++++++++ ice-9/ChangeLog | 8 ++++++++ libguile/ChangeLog | 4 ++++ qt/ChangeLog | 4 ++++ srfi/ChangeLog | 7 +++++++ 5 files changed, 56 insertions(+) diff --git a/ChangeLog b/ChangeLog index 7e0642ac7..3f0f22c58 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,36 @@ +2002-02-24 Rob Browning + + * GUILE-VERSION: move all but guile-readline library versioning + information here. guile-readline is still standalone. Bump + CURRENT interfaces to 15 to allow some headroom for 1.6 release at + Thi-Thien's request. + + * configure.in: AC_SUBST the centralized shared lib versioning + variables from ./GUILE-VERSION. + (LIBQTHREADS_INTERFACE_CURRENT): new AC_SUBST. + (LIBQTHREADS_INTERFACE_REVISION): new AC_SUBST. + (LIBQTHREADS_INTERFACE_AGE): new AC_SUBST. + (LIBQTHREADS_INTERFACE): new AC_SUBST. + (LIBGUILE_INTERFACE_CURRENT): new AC_SUBST. + (LIBGUILE_INTERFACE_REVISION): new AC_SUBST. + (LIBGUILE_INTERFACE_AGE): new AC_SUBST. + (LIBGUILE_INTERFACE): new AC_SUBST. + (LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT): new AC_SUBST. + (LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION): new AC_SUBST. + (LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE): new AC_SUBST. + (LIBGUILE_SRFI_SRFI_4_INTERFACE): new AC_SUBST. + (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT): new AC_SUBST. + (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION): new AC_SUBST. + (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE): new AC_SUBST. + (LIBGUILE_SRFI_SRFI_13_14_INTERFACE): new AC_SUBST. + + * autogen.sh: make absolutely sure we can't have stale files from + old versions lying around the libltdl dir since libtoolize + doesn't. Also hack libltdl's configure.in to require autoconf 2.5 + so the main tree and libltdl can't get out of sync again. + + * RELEASE: update release building instructions. + 2002-02-21 Neil Jerram * acinclude.m4 (GUILE_HEADER_LIBC_WITH_UNISTD): Use [] rather than diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index d8c81c5a9..a41923c83 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2002-02-24 Rob Browning + + * syncase.scm (gensym): redefine locally so we can control it's + properties. This is in preparation for changing the future public + gensym to produce unreadable symbols. + + * psyntax.pp: updated to reflect new syncase.scm. + 2002-02-07 Thien-Thi Nguyen * regex.scm: Add commentary; nfc. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c6d8dac9a..4b5cb4aae 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2002-02-24 Rob Browning + + * .cvsignore: add stamp-h1. + 2002-02-21 Neil Jerram * unif.c (scm_array_to_list): Correct name, which had been diff --git a/qt/ChangeLog b/qt/ChangeLog index ae4e4d285..da7c9509b 100644 --- a/qt/ChangeLog +++ b/qt/ChangeLog @@ -1,3 +1,7 @@ +2002-02-24 Rob Browning + + * Makefile.am (libqthreads_la_LDFLAGS): use @LIBQTHREADS_INTERFACE@. + 2001-11-21 Gary Houston * Makefile.am (OMIT_DEPENDENCIES): removed, since it seems to be diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 1ae9ac95d..85d30f6f8 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,10 @@ +2002-02-24 Rob Browning + + * Makefile.am (libguile_srfi_srfi_4_la_LDFLAGS): use + @LIBGUILE_SRFI_SRFI_4_INTERFACE@. + (libguile_srfi_srfi_13_14_la_LDFLAGS): use + @LIBGUILE_SRFI_SRFI_13_14_INTERFACE@. + 2002-02-23 Neil Jerram * srfi-19.scm (priv:month-assoc): Correct numbers so that they From 4f2716b6f65407e497fc7814773e635a42ee2484 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Mon, 25 Feb 2002 22:07:52 +0000 Subject: [PATCH 72/81] * convert.c: include for convert_i.c. --- libguile/ChangeLog | 4 ++++ libguile/convert.c | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4b5cb4aae..bc17890a4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2002-02-25 Gary Houston + + * convert.c: include for convert_i.c. + 2002-02-24 Rob Browning * .cvsignore: add stamp-h1. diff --git a/libguile/convert.c b/libguile/convert.c index 43d5d7107..cbec8fa2a 100644 --- a/libguile/convert.c +++ b/libguile/convert.c @@ -52,6 +52,10 @@ #include "libguile/convert.h" +#ifdef HAVE_STRING_H +#include +#endif + #define CTYPE char #define SCM2CTYPES_FN "scm_c_scm2chars" #define SCM2CTYPES scm_c_scm2chars From bac0e2326323206f396609ffbef092d11abb6474 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 25 Feb 2002 22:48:21 +0000 Subject: [PATCH 73/81] * num2integral.i.c (NUM2INTEGRAL): Fixed signedness problem. --- libguile/ChangeLog | 4 ++++ libguile/num2integral.i.c | 30 +++++++++++++++++------------- 2 files changed, 21 insertions(+), 13 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bc17890a4..fc6852e93 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2002-01-10 Dirk Herrmann + + * num2integral.i.c (NUM2INTEGRAL): Fixed signedness problem. + 2002-02-25 Gary Houston * convert.c: include for convert_i.c. diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c index b6e8a9b5f..a9bd5c718 100644 --- a/libguile/num2integral.i.c +++ b/libguile/num2integral.i.c @@ -27,17 +27,21 @@ NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) scm_out_of_range (s_caller, num); #endif - if (sizeof (ITYPE) >= sizeof (scm_t_signed_bits)) - /* can't fit anything too big for this type in an inum - anyway */ - return (ITYPE) n; - else - { /* an inum can be out of range, so check */ - if (((ITYPE)n) != n) - scm_out_of_range (s_caller, num); - else - return (ITYPE) n; - } +#if SIZEOF_ITYPE >= SIZEOF_SCM_T_BITS + /* the target type is large enough to hold any possible inum */ + return (ITYPE) n; +#else + /* an inum can be out of range, so check */ +#ifdef UNSIGNED + /* n is known to be >= 0 */ + if ((scm_t_bits) n > UNSIGNED_ITYPE_MAX) + scm_out_of_range (s_caller, num); +#else + if (((ITYPE)n) != n) + scm_out_of_range (s_caller, num); +#endif + return (ITYPE) n; +#endif /* SIZEOF_ITYPE >= SIZEOF_SCM_T_BITS */ } else if (SCM_BIGP (num)) { /* bignum */ @@ -78,9 +82,9 @@ NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) scm_out_of_range (s_caller, num); } #endif - + #else /* SIZEOF_ITYPE >= SIZEOF_SCM_T_BITS */ - scm_out_of_range (s_caller, num); + scm_out_of_range (s_caller, num); #endif } From 646052c0dc712c9798a4dafeddd50d3b864403dd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 25 Feb 2002 23:22:16 +0000 Subject: [PATCH 74/81] * gc.c (scm_gc_sweep): Make it compile even when deprecated features are excluded. --- libguile/ChangeLog | 5 +++++ libguile/gc.c | 10 +++++++++- 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index fc6852e93..dbd473b30 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2002-01-10 Dirk Herrmann + + * gc.c (scm_gc_sweep): Make it compile even when deprecated + features are excluded. + 2002-01-10 Dirk Herrmann * num2integral.i.c (NUM2INTEGRAL): Fixed signedness problem. diff --git a/libguile/gc.c b/libguile/gc.c index 3c901b0dd..6e781f721 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1709,6 +1709,7 @@ scm_gc_sweep () if (mm != 0) { +#if SCM_ENABLE_DEPRECATED == 1 scm_c_issue_deprecation_warning ("Returning non-0 from a port free function is " "deprecated. Use scm_gc_free et al instead."); @@ -1716,8 +1717,11 @@ scm_gc_sweep () ("(You just returned non-0 while freeing a %s.)", SCM_PTOBNAME (k)); m += mm; +#else + abort (); +#endif } - + SCM_SETSTREAM (scmptr, 0); scm_remove_from_port_table (scmptr); scm_gc_ports_collected++; @@ -1755,6 +1759,7 @@ scm_gc_sweep () mm = scm_smobs[k].free (scmptr); if (mm != 0) { +#if SCM_ENABLE_DEPRECATED == 1 scm_c_issue_deprecation_warning ("Returning non-0 from a smob free function is " "deprecated. Use scm_gc_free et al instead."); @@ -1762,6 +1767,9 @@ scm_gc_sweep () ("(You just returned non-0 while freeing a %s.)", SCM_SMOBNAME (k)); m += mm; +#else + abort(); +#endif } } break; From 89d7a92c0a815a2b997e284033ed8d149808e1ad Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Mon, 25 Feb 2002 23:27:30 +0000 Subject: [PATCH 75/81] * Fixed changelog entry. --- libguile/ChangeLog | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dbd473b30..5a3072f23 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,9 +1,9 @@ -2002-01-10 Dirk Herrmann +2002-02-25 Dirk Herrmann * gc.c (scm_gc_sweep): Make it compile even when deprecated features are excluded. -2002-01-10 Dirk Herrmann +2002-02-25 Dirk Herrmann * num2integral.i.c (NUM2INTEGRAL): Fixed signedness problem. From 88a1ce4c0e64dd205dd69c739f799f32a8f98e6e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 07:16:12 +0000 Subject: [PATCH 76/81] (LIBGUILEREADLINE-VERSION): Use this file from $srcdir. --- guile-readline/configure.in | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/guile-readline/configure.in b/guile-readline/configure.in index b10d1a4b9..ea51027cb 100644 --- a/guile-readline/configure.in +++ b/guile-readline/configure.in @@ -26,7 +26,7 @@ fi AC_SUBST(EXTRA_DEFS) for termlib in ncurses curses termcap terminfo termlib ; do - AC_CHECK_LIB(${termlib}, tgoto, + AC_CHECK_LIB(${termlib}, tgoto, [LIBS="-l${termlib} $LIBS"; break]) done @@ -74,20 +74,20 @@ hook () sigaction (SIGWINCH, NULL, &action); rl_cleanup_after_signal(); - + /* exit with 0 if readline disabled SA_RESTART */ exit (action.sa_flags & SA_RESTART); } - + int main () { struct sigaction action; - + sigaction (SIGWINCH, NULL, &action); action.sa_flags |= SA_RESTART; sigaction (SIGWINCH, &action, NULL); - + rl_pre_input_hook = hook; readline (""); }], @@ -119,7 +119,7 @@ fi AC_CHECK_FUNCS(strdup) -. ./LIBGUILEREADLINE-VERSION +. $srcdir/LIBGUILEREADLINE-VERSION AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT) AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION) AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE) From f99b18faa60c4a5687e270bcb0a1a2adf59a490b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 07:18:32 +0000 Subject: [PATCH 77/81] *** empty log message *** --- guile-readline/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index a34865503..29491889e 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2002-02-25 Thien-Thi Nguyen + + * configure.in (LIBGUILEREADLINE-VERSION): + Look for this file in $srcdir. + 2002-02-24 Rob Browning * configure.in: source ./LIBGUILEREADLINE-VERSION for version info From d62ccf28d97380c67fbc457c202b18338e3574c8 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 09:56:37 +0000 Subject: [PATCH 78/81] Initial revision --- am/Makefile.am | 28 ++++++++++++++++++++++++++++ am/README | 3 +++ am/pre-inst-guile | 34 ++++++++++++++++++++++++++++++++++ 3 files changed, 65 insertions(+) create mode 100644 am/Makefile.am create mode 100644 am/README create mode 100644 am/pre-inst-guile diff --git a/am/Makefile.am b/am/Makefile.am new file mode 100644 index 000000000..a4bfbc415 --- /dev/null +++ b/am/Makefile.am @@ -0,0 +1,28 @@ +## Process this file with Automake to create Makefile.in +## +## Copyright (C) 2002 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = gnu + +am_frags = pre-inst-guile + +EXTRA_DIST = $(am_frags) + +## Makefile.am ends here diff --git a/am/README b/am/README new file mode 100644 index 000000000..c7883c37c --- /dev/null +++ b/am/README @@ -0,0 +1,3 @@ +data directory: automake frags + +do not name files using extension ".am", as automake is overzealous sometimes. diff --git a/am/pre-inst-guile b/am/pre-inst-guile new file mode 100644 index 000000000..2cf240104 --- /dev/null +++ b/am/pre-inst-guile @@ -0,0 +1,34 @@ +## am/pre-inst-guile --- define preinstguile and preinstguiletool vars + +## Copyright (C) 2002 Free Software Foundation +## +## This file is part of GUILE. +## +## GUILE 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. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +## Commentary: + +## This fragment defines two variables: preinstguile, preinstguiletool. +## It can be included in any Makefile.am by adding the line: +## include $(top_srcdir)/am/pre-inst-guile +## See devel/build/pre-inst-guile.text (CVS only) for more info. + +## Code: + +preinstguile = $(top_builddir_absolute)/pre-inst-guile +preinstguiletool = GUILE="$(preinstguile)" $(top_srcdir)/scripts + +## am/pre-inst-guile ends here From 8323051cdb4dd85f006e1048036f8c36c0a55db3 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 09:57:29 +0000 Subject: [PATCH 79/81] *** empty log message *** --- am/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 am/ChangeLog diff --git a/am/ChangeLog b/am/ChangeLog new file mode 100644 index 000000000..16ea39030 --- /dev/null +++ b/am/ChangeLog @@ -0,0 +1,4 @@ +2002-02-26 Thien-Thi Nguyen + + * pre-inst-guile, Makefile.am, README: New files. + From e13b7eb897a99c3fa44d886fe6e276ca34370d18 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:03:45 +0000 Subject: [PATCH 80/81] bye bye --- pre-inst-guile | 0 pre-inst-guile.am | 0 2 files changed, 0 insertions(+), 0 deletions(-) delete mode 100755 pre-inst-guile delete mode 100644 pre-inst-guile.am diff --git a/pre-inst-guile b/pre-inst-guile deleted file mode 100755 index e69de29bb..000000000 diff --git a/pre-inst-guile.am b/pre-inst-guile.am deleted file mode 100644 index e69de29bb..000000000 From 99d8f2d5a6e357c51e9578952687ff0f87e4098d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 26 Feb 2002 10:04:14 +0000 Subject: [PATCH 81/81] Initial revision --- pre-inst-guile.in | 83 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 83 insertions(+) create mode 100644 pre-inst-guile.in diff --git a/pre-inst-guile.in b/pre-inst-guile.in new file mode 100644 index 000000000..428e04b14 --- /dev/null +++ b/pre-inst-guile.in @@ -0,0 +1,83 @@ +#!/bin/sh + +# Copyright (C) 2002 Free Software Foundation +# +# This file is part of GUILE. +# +# GUILE 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. +# +# GUILE is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public +# License along with GUILE; see the file COPYING. If not, write +# to the Free Software Foundation, Inc., 59 Temple Place, Suite +# 330, Boston, MA 02111-1307 USA + +# Commentary: + +# Usage: pre-inst-guile [ARGS] +# +# This script arranges for the environment to support, and eventaully execs, +# the uninstalled binary guile executable located somewhere under libguile/, +# passing ARGS to it. In the process, env var GUILE is clobbered, and the +# following env vars are modified (but not clobbered): +# GUILE_LOAD_PATH +# LTDL_LOAD_PATH +# +# This script can be used as a drop-in replacement for $bindir/guile; +# if there is a discrepency in behavior, that's a bug. + +# Code: + +# config +subdirs_with_ltlibs="srfi guile-readline" # maintain me + +# env (set by configure) +top_srcdir="@top_srcdir@" +top_builddir="@top_builddir_absolute@" + +[ x"$top_srcdir" = x -o ! -d "$top_srcdir" -o \ + x"$top_builddir" = x -o ! -d "$top_builddir" ] && { + echo $0: bad environment + echo top_srcdir=$top_srcdir + echo top_builddir=$top_builddir + exit 1 +} + +# handle GUILE_LOAD_PATH (no clobber) +if [ x"$GUILE_LOAD_PATH" = x ] ; then + GUILE_LOAD_PATH="${top_srcdir}" +else + # This hair prevents double inclusion. + # The ":" prevents prefix aliasing. + case x"$GUILE_LOAD_PATH" in x*${top_srcdir}:*) ;; + *) GUILE_LOAD_PATH="${top_srcdir}:$GUILE_LOAD_PATH" ;; + esac +fi +export GUILE_LOAD_PATH + +# handle LTDL_LIBRARY_PATH (no clobber) +ltdl_prefix="" +for dir in $subdirs_with_ltlibs ; do + ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}" +done +LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH" +export LTDL_LIBRARY_PATH + +# set GUILE (clobber) +GUILE=${top_builddir}/libguile/guile +export GUILE + +# do it +exec $GUILE "$@" + +# never reached +exit 1 + +# pre-inst-guile ends here