Anonymous avatar Anonymous committed c9f2cc9

[svn] Reduce example file size.

Comments (0)

Files changed (7)

tests/examplefiles/boot-9.scm

 (define (local-set! names val) (nested-set! (current-module) names val))
 (define (local-define names val) (nested-define! (current-module) names val))
 (define (local-remove names) (nested-remove! (current-module) names))
-
-
-
-;;; {The (app) module}
-;;;
-;;; The root of conventionally named objects not directly in the top level.
-;;;
-;;; (app modules)
-;;; (app modules guile)
-;;;
-;;; The directory of all modules and the standard root module.
-;;;
-
-(define (module-public-interface m)
-  (module-ref m '%module-public-interface #f))
-(define (set-module-public-interface! m i)
-  (module-define! m '%module-public-interface i))
-(define (set-system-module! m s)
-  (set-procedure-property! (module-eval-closure m) 'system-module s))
-(define the-root-module (make-root-module))
-(define the-scm-module (make-scm-module))
-(set-module-public-interface! the-root-module the-scm-module)
-(set-module-name! the-root-module '(guile))
-(set-module-name! the-scm-module '(guile))
-(set-module-kind! the-scm-module 'interface)
-(for-each set-system-module! (list the-root-module the-scm-module) '(#t #t))
-
-;; NOTE: This binding is used in libguile/modules.c.
-;;
-(define (make-modules-in module name)
-  (if (null? name)
-      module
-      (cond
-       ((module-ref module (car name) #f)
-	=> (lambda (m) (make-modules-in m (cdr name))))
-       (else	(let ((m (make-module 31)))
-		  (set-module-kind! m 'directory)
-		  (set-module-name! m (append (or (module-name module)
-						  '())
-					      (list (car name))))
-		  (module-define! module (car name) m)
-		  (make-modules-in m (cdr name)))))))
-
-(define (beautify-user-module! module)
-  (let ((interface (module-public-interface module)))
-    (if (or (not interface)
-	    (eq? interface module))
-	(let ((interface (make-module 31)))
-	  (set-module-name! interface (module-name module))
-	  (set-module-kind! interface 'interface)
-	  (set-module-public-interface! module interface))))
-  (if (and (not (memq the-scm-module (module-uses module)))
-	   (not (eq? module the-root-module)))
-      (set-module-uses! module (append (module-uses module) (list the-scm-module)))))
-
-;; NOTE: This binding is used in libguile/modules.c.
-;;
-(define (resolve-module name . maybe-autoload)
-  (let ((full-name (append '(app modules) name)))
-    (let ((already (local-ref full-name)))
-      (if already
-	  ;; The module already exists...
-	  (if (and (or (null? maybe-autoload) (car maybe-autoload))
-		   (not (module-public-interface already)))
-	      ;; ...but we are told to load and it doesn't contain source, so
-	      (begin
-		(try-load-module name)
-		already)
-	      ;; simply return it.
-	      already)
-	  (begin
-	    ;; Try to autoload it if we are told so
-	    (if (or (null? maybe-autoload) (car maybe-autoload))
-		(try-load-module name))
-	    ;; Get/create it.
-	    (make-modules-in (current-module) full-name))))))
-
-;; Cheat.  These bindings are needed by modules.c, but we don't want
-;; to move their real definition here because that would be unnatural.
-;;
-(define try-module-autoload #f)
-(define process-define-module #f)
-(define process-use-modules #f)
-(define module-export! #f)
-
-;; This boots the module system.  All bindings needed by modules.c
-;; must have been defined by now.
-;;
-(set-current-module the-root-module)
-
-(define app (make-module 31))
-(local-define '(app modules) (make-module 31))
-(local-define '(app modules guile) the-root-module)
-
-;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
-
-(define (try-load-module name)
-  (or (begin-deprecated (try-module-linked name))
-      (try-module-autoload name)
-      (begin-deprecated (try-module-dynamic-link name))))
-
-(define (purify-module! module)
-  "Removes bindings in MODULE which are inherited from the (guile) module."
-  (let ((use-list (module-uses module)))
-    (if (and (pair? use-list)
-	     (eq? (car (last-pair use-list)) the-scm-module))
-	(set-module-uses! module (reverse (cdr (reverse use-list)))))))
-
-;; Return a module that is an interface to the module designated by
-;; NAME.
-;;
-;; `resolve-interface' takes two keyword arguments:
-;;
-;;   #:select SELECTION
-;;
-;; SELECTION is a list of binding-specs to be imported; A binding-spec
-;; is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG
-;; is the name in the used module and SEEN is the name in the using
-;; module.  Note that SEEN is also passed through RENAMER, below.  The
-;; default is to select all bindings.  If you specify no selection but
-;; a renamer, only the bindings that already exist in the used module
-;; are made available in the interface.  Bindings that are added later
-;; are not picked up.
-;;
-;;   #:renamer RENAMER
-;;
-;; RENAMER is a procedure that takes a symbol and returns its new
-;; name.  The default is to not perform any renaming.
-;;
-;; Signal "no code for module" error if module name is not resolvable
-;; or its public interface is not available.  Signal "no binding"
-;; error if selected binding does not exist in the used module.
-;;
-(define (resolve-interface name . args)
-
-  (define (get-keyword-arg args kw def)
-    (cond ((memq kw args)
-	   => (lambda (kw-arg)
-		(if (null? (cdr kw-arg))
-		    (error "keyword without value: " kw))
-		(cadr kw-arg)))
-	  (else
-	   def)))
-
-  (let* ((select (get-keyword-arg args #:select #f))
-	 (renamer (get-keyword-arg args #:renamer identity))
-         (module (resolve-module name))
-         (public-i (and module (module-public-interface module))))
-    (and (or (not module) (not public-i))
-         (error "no code for module" name))
-    (if (and (not select) (eq? renamer identity))
-        public-i
-        (let ((selection (or select (module-map (lambda (sym var) sym)
-						public-i)))
-              (custom-i (make-module 31)))
-          (set-module-kind! custom-i 'interface)
-	  ;; XXX - should use a lazy binder so that changes to the
-	  ;; used module are picked up automatically.
-          (for-each (lambda (bspec)
-                      (let* ((direct? (symbol? bspec))
-                             (orig (if direct? bspec (car bspec)))
-                             (seen (if direct? bspec (cdr bspec))))
-                        (module-add! custom-i (renamer seen)
-                                     (or (module-local-variable public-i orig)
-                                         (module-local-variable module orig)
-                                         (error
-                                          ;; fixme: format manually for now
-                                          (simple-format
-                                           #f "no binding `~A' in module ~A"
-                                           orig name))))))
-                    selection)
-          custom-i))))
-
-(define (symbol-prefix-proc prefix)
-  (lambda (symbol)
-    (symbol-append prefix symbol)))
-
-;; This function is called from "modules.c".  If you change it, be
-;; sure to update "modules.c" as well.
-
-(define (process-define-module args)
-  (let* ((module-id (car args))
-         (module (resolve-module module-id #f))
-         (kws (cdr args))
-         (unrecognized (lambda (arg)
-                         (error "unrecognized define-module argument" arg))))
-    (beautify-user-module! module)
-    (let loop ((kws kws)
-	       (reversed-interfaces '())
-	       (exports '())
-	       (re-exports '()))
-      (if (null? kws)
-	  (begin
-	    (for-each (lambda (interface)
-			(module-use! module interface))
-		      (reverse reversed-interfaces))
-	    (module-export! module exports)
-	    (module-re-export! module re-exports))
-	  (case (car kws)
-	    ((#:use-module #:use-syntax)
-	     (or (pair? (cdr kws))
-		 (unrecognized kws))
-	     (let* ((interface-args (cadr kws))
-		    (interface (apply resolve-interface interface-args)))
-	       (and (eq? (car kws) 'use-syntax)
-		    (or (symbol? (car spec))
-			(error "invalid module name for use-syntax"
-			       spec))
-		    (set-module-transformer!
-		     module
-		     (module-ref interface (car
-					    (last-pair (car interface-args)))
-				 #f)))
-	       (loop (cddr kws)
-		     (cons interface reversed-interfaces)
-		     exports
-		     re-exports)))
-	    ((#:autoload)
-	     (or (and (pair? (cdr kws)) (pair? (cddr kws)))
-		 (unrecognized kws))
-	     (loop (cdddr kws)
-		   (cons (make-autoload-interface module
-						  (cadr kws)
-						  (caddr kws))
-			 reversed-interfaces)
-		   exports
-		   re-exports))
-	    ((#:no-backtrace)
-	     (set-system-module! module #t)
-	     (loop (cdr kws) reversed-interfaces exports re-exports))
-	    ((#:pure)
-	     (purify-module! module)
-	     (loop (cdr kws) reversed-interfaces exports re-exports))
-	    ((#:export #:export-syntax)
-	     (or (pair? (cdr kws))
-		 (unrecognized kws))
-	     (loop (cddr kws)
-		   reversed-interfaces
-		   (append (cadr kws) exports)
-		   re-exports))
-	    ((#:re-export #:re-export-syntax)
-	     (or (pair? (cdr kws))
-		 (unrecognized kws))
-	     (loop (cddr kws)
-		   reversed-interfaces
-		   exports
-		   (append (cadr kws) re-exports)))
-	    (else
-	     (unrecognized kws)))))
-    module))
-
-;;; {Autoload}
-
-(define (make-autoload-interface module name bindings)
-  (let ((b (lambda (a sym definep)
-	     (and (memq sym bindings)
-		  (let ((i (module-public-interface (resolve-module name))))
-		    (if (not i)
-			(error "missing interface for module" name))
-		    ;; Replace autoload-interface with interface
-		    (set-car! (memq a (module-uses module)) i)
-		    (module-local-variable i sym))))))
-    (module-constructor #() '() b #f #f name 'autoload
-			'() (make-weak-value-hash-table 31) 0)))
-
-;;; {Compiled module}
-
-(define load-compiled #f)
-
-
-;;; {Autoloading modules}
-
-(define autoloads-in-progress '())
-
-;; This function is called from "modules.c".  If you change it, be
-;; sure to update "modules.c" as well.
-
-(define (try-module-autoload module-name)
-  (let* ((reverse-name (reverse module-name))
-	 (name (symbol->string (car reverse-name)))
-	 (dir-hint-module-name (reverse (cdr reverse-name)))
-	 (dir-hint (apply string-append
-			  (map (lambda (elt)
-				 (string-append (symbol->string elt) "/"))
-			       dir-hint-module-name))))
-    (resolve-module dir-hint-module-name #f)
-    (and (not (autoload-done-or-in-progress? dir-hint name))
-	 (let ((didit #f))
-	   (define (load-file proc file)
-	     (save-module-excursion (lambda () (proc file)))
-	     (set! didit #t))
-	   (dynamic-wind
-	    (lambda () (autoload-in-progress! dir-hint name))
-	    (lambda ()
-	      (let ((file (in-vicinity dir-hint name)))
-		(cond ((and load-compiled
-			    (%search-load-path (string-append file ".go")))
-		       => (lambda (full)
-			    (load-file load-compiled full)))
-		      ((%search-load-path file)
-		       => (lambda (full)
-			    (load-file primitive-load full))))))
-	    (lambda () (set-autoloaded! dir-hint name didit)))
-	   didit))))
-
-
-;;; Dynamic linking of modules
-
-;; This method of dynamically linking Guile Extensions is deprecated.
-;; Use `load-extension' explicitely from Scheme code instead.
-
-(begin-deprecated
-
- (define (split-c-module-name str)
-   (let loop ((rev '())
-	      (start 0)
-	      (pos 0)
-	      (end (string-length str)))
-     (cond
-      ((= pos end)
-       (reverse (cons (string->symbol (substring str start pos)) rev)))
-      ((eq? (string-ref str pos) #\space)
-       (loop (cons (string->symbol (substring str start pos)) rev)
-	     (+ pos 1)
-	     (+ pos 1)
-	     end))
-      (else
-       (loop rev start (+ pos 1) end)))))
-
- (define (convert-c-registered-modules dynobj)
-   (let ((res (map (lambda (c)
-		     (list (split-c-module-name (car c)) (cdr c) dynobj))
-		   (c-registered-modules))))
-     (c-clear-registered-modules)
-     res))
-
- (define registered-modules '())
-
- (define (register-modules dynobj)
-   (set! registered-modules
-	 (append! (convert-c-registered-modules dynobj)
-		  registered-modules)))
-
- (define (warn-autoload-deprecation modname)
-   (issue-deprecation-warning
-    "Autoloading of compiled code modules is deprecated."
-    "Write a Scheme file instead that uses `load-extension'.")
-   (issue-deprecation-warning
-    (simple-format #f "(You just autoloaded module ~S.)" modname)))
-
- (define (init-dynamic-module modname)
-   ;; Register any linked modules which have been registered on the C level
-   (register-modules #f)
-   (or-map (lambda (modinfo)
-	     (if (equal? (car modinfo) modname)
-		 (begin
-		   (warn-autoload-deprecation modname)
-		   (set! registered-modules (delq! modinfo registered-modules))
-		   (let ((mod (resolve-module modname #f)))
-		     (save-module-excursion
-		      (lambda ()
-			(set-current-module mod)
-			(set-module-public-interface! mod mod)
-			(dynamic-call (cadr modinfo) (caddr modinfo))
-			))
-		     #t))
-		 #f))
-	   registered-modules))
-
- (define (dynamic-maybe-call name dynobj)
-   (catch #t				; could use false-if-exception here
-	  (lambda ()
-	    (dynamic-call name dynobj))
-	  (lambda args
-	    #f)))
-
- (define (dynamic-maybe-link filename)
-   (catch #t				; could use false-if-exception here
-	  (lambda ()
-	    (dynamic-link filename))
-	  (lambda args
-	    #f)))
-
- (define (find-and-link-dynamic-module module-name)
-   (define (make-init-name mod-name)
-     (string-append "scm_init"
-		    (list->string (map (lambda (c)
-					 (if (or (char-alphabetic? c)
-						 (char-numeric? c))
-					     c
-					     #\_))
-				       (string->list mod-name)))
-		    "_module"))
-
-   ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
-   ;; and the `libname' (the name of the module prepended by `lib') in the cdr
-   ;; field.  For example, if MODULE-NAME is the list (inet tcp-ip udp), then
-   ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
-   (let ((subdir-and-libname
-	  (let loop ((dirs "")
-		     (syms module-name))
-	    (if (null? (cdr syms))
-		(cons dirs (string-append "lib" (symbol->string (car syms))))
-		(loop (string-append dirs (symbol->string (car syms)) "/")
-		      (cdr syms)))))
-	 (init (make-init-name (apply string-append
-				      (map (lambda (s)
-					     (string-append "_"
-							    (symbol->string s)))
-					   module-name)))))
-     (let ((subdir (car subdir-and-libname))
-	   (libname (cdr subdir-and-libname)))
-
-       ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'.  If that
-       ;; file exists, fetch the dlname from that file and attempt to link
-       ;; against it.  If `subdir/libfoo.la' does not exist, or does not seem
-       ;; to name any shared library, look for `subdir/libfoo.so' instead and
-       ;; link against that.
-       (let check-dirs ((dir-list %load-path))
-	 (if (null? dir-list)
-	     #f
-	     (let* ((dir (in-vicinity (car dir-list) subdir))
-		    (sharlib-full
-		     (or (try-using-libtool-name dir libname)
-			 (try-using-sharlib-name dir libname))))
-	       (if (and sharlib-full (file-exists? sharlib-full))
-		   (link-dynamic-module sharlib-full init)
-		   (check-dirs (cdr dir-list)))))))))
-
- (define (try-using-libtool-name libdir libname)
-   (let ((libtool-filename (in-vicinity libdir
-					(string-append libname ".la"))))
-     (and (file-exists? libtool-filename)
-	  libtool-filename)))
-
- (define (try-using-sharlib-name libdir libname)
-   (in-vicinity libdir (string-append libname ".so")))
-
- (define (link-dynamic-module filename initname)
-   ;; Register any linked modules which have been registered on the C level
-   (register-modules #f)
-   (let ((dynobj (dynamic-link filename)))
-     (dynamic-call initname dynobj)
-     (register-modules dynobj)))
-
- (define (try-module-linked module-name)
-   (init-dynamic-module module-name))
-
- (define (try-module-dynamic-link module-name)
-   (and (find-and-link-dynamic-module module-name)
-	(init-dynamic-module module-name))))
-;; end of deprecated section
-
-
-(define autoloads-done '((guile . guile)))
-
-(define (autoload-done-or-in-progress? p m)
-  (let ((n (cons p m)))
-    (->bool (or (member n autoloads-done)
-		(member n autoloads-in-progress)))))
-
-(define (autoload-done! p m)
-  (let ((n (cons p m)))
-    (set! autoloads-in-progress
-	  (delete! n autoloads-in-progress))
-    (or (member n autoloads-done)
-	(set! autoloads-done (cons n autoloads-done)))))
-
-(define (autoload-in-progress! p m)
-  (let ((n (cons p m)))
-    (set! autoloads-done
-	  (delete! n autoloads-done))
-    (set! autoloads-in-progress (cons n autoloads-in-progress))))
-
-(define (set-autoloaded! p m done?)
-  (if done?
-      (autoload-done! p m)
-      (let ((n (cons p m)))
-	(set! autoloads-done (delete! n autoloads-done))
-	(set! autoloads-in-progress (delete! n autoloads-in-progress)))))
-
-
-
-
-;; {EVAL-CASE}
-;;
-;; (eval-case ((situation*) forms)* (else forms)?)
-;;
-;; Evaluate certain code based on the situation that eval-case is used
-;; in.  The only defined situation right now is `load-toplevel' which
-;; triggers for code evaluated at the top-level, for example from the
-;; REPL or when loading a file.
-
-(define eval-case
-  (procedure->memoizing-macro
-   (lambda (exp env)
-     (define (toplevel-env? env)
-       (or (not (pair? env)) (not (pair? (car env)))))
-     (define (syntax)
-       (error "syntax error in eval-case"))
-     (let loop ((clauses (cdr exp)))
-       (cond
-	((null? clauses)
-	 #f)
-	((not (list? (car clauses)))
-	 (syntax))
-	((eq? 'else (caar clauses))
-	 (or (null? (cdr clauses))
-	     (syntax))
-	 (cons 'begin (cdar clauses)))
-	((not (list? (caar clauses)))
-	 (syntax))
-	((and (toplevel-env? env)
-	      (memq 'load-toplevel (caar clauses)))
-	 (cons 'begin (cdar clauses)))
-	(else
-	 (loop (cdr clauses))))))))
-
-
-;;; {Macros}
-;;;
-
-(define (primitive-macro? m)
-  (and (macro? m)
-       (not (macro-transformer m))))
-
-;;; {Defmacros}
-;;;
-(define macro-table (make-weak-key-hash-table 523))
-(define xformer-table (make-weak-key-hash-table 523))
-
-(define (defmacro? m)  (hashq-ref macro-table m))
-(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
-(define (defmacro-transformer m) (hashq-ref xformer-table m))
-(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
-
-(define defmacro:transformer
-  (lambda (f)
-    (let* ((xform (lambda (exp env)
-		    (copy-tree (apply f (cdr exp)))))
-	   (a (procedure->memoizing-macro xform)))
-      (assert-defmacro?! a)
-      (set-defmacro-transformer! a f)
-      a)))
-
-
-(define defmacro
-  (let ((defmacro-transformer
-	  (lambda (name parms . body)
-	    (let ((transformer `(lambda ,parms ,@body)))
-	      `(eval-case
-		((load-toplevel)
-		 (define ,name (defmacro:transformer ,transformer)))
-		(else
-		 (error "defmacro can only be used at the top level")))))))
-    (defmacro:transformer defmacro-transformer)))
-
-(define defmacro:syntax-transformer
-  (lambda (f)
-    (procedure->syntax
-	      (lambda (exp env)
-		(copy-tree (apply f (cdr exp)))))))
-
-
-;; XXX - should the definition of the car really be looked up in the
-;; current module?
-
-(define (macroexpand-1 e)
-  (cond
-   ((pair? e) (let* ((a (car e))
-		     (val (and (symbol? a) (local-ref (list a)))))
-		(if (defmacro? val)
-		    (apply (defmacro-transformer val) (cdr e))
-		    e)))
-   (#t e)))
-
-(define (macroexpand e)
-  (cond
-   ((pair? e) (let* ((a (car e))
-		     (val (and (symbol? a) (local-ref (list a)))))
-		(if (defmacro? val)
-		    (macroexpand (apply (defmacro-transformer val) (cdr e)))
-		    e)))
-   (#t e)))
-
-(provide 'defmacro)
-
-
-
-;;; {Run-time options}
-
-(define define-option-interface
-  (let* ((option-name car)
-	 (option-value cadr)
-	 (option-documentation caddr)
-
-	 (print-option (lambda (option)
-			 (display (option-name option))
-			 (if (< (string-length
-				 (symbol->string (option-name option)))
-				8)
-			     (display #\tab))
-			 (display #\tab)
-			 (display (option-value option))
-			 (display #\tab)
-			 (display (option-documentation option))
-			 (newline)))
-
-	 ;; Below follow the macros defining the run-time option interfaces.
-
-	 (make-options (lambda (interface)
-			 `(lambda args
-			    (cond ((null? args) (,interface))
-				  ((list? (car args))
-				   (,interface (car args)) (,interface))
-				  (else (for-each ,print-option
-						  (,interface #t)))))))
-
-	 (make-enable (lambda (interface)
-			`(lambda flags
-			   (,interface (append flags (,interface)))
-			   (,interface))))
-
-	 (make-disable (lambda (interface)
-			 `(lambda flags
-			    (let ((options (,interface)))
-			      (for-each (lambda (flag)
-					  (set! options (delq! flag options)))
-					flags)
-			      (,interface options)
-			      (,interface)))))
-
-	 (make-set! (lambda (interface)
-		      `((name exp)
-			(,'quasiquote
-			 (begin (,interface (append (,interface)
-						    (list '(,'unquote name)
-							  (,'unquote exp))))
-				(,interface)))))))
-    (procedure->macro
-     (lambda (exp env)
-       (cons 'begin
-	     (let* ((option-group (cadr exp))
-		    (interface (car option-group)))
-	       (append (map (lambda (name constructor)
-			      `(define ,name
-				 ,(constructor interface)))
-			    (cadr option-group)
-			    (list make-options
-				  make-enable
-				  make-disable))
-		       (map (lambda (name constructor)
-			      `(defmacro ,name
-				 ,@(constructor interface)))
-			    (caddr option-group)
-			    (list make-set!)))))))))
-
-(define-option-interface
-  (eval-options-interface
-   (eval-options eval-enable eval-disable)
-   (eval-set!)))
-
-(define-option-interface
-  (debug-options-interface
-   (debug-options debug-enable debug-disable)
-   (debug-set!)))
-
-(define-option-interface
-  (evaluator-traps-interface
-   (traps trap-enable trap-disable)
-   (trap-set!)))
-
-(define-option-interface
-  (read-options-interface
-   (read-options read-enable read-disable)
-   (read-set!)))
-
-(define-option-interface
-  (print-options-interface
-   (print-options print-enable print-disable)
-   (print-set!)))
-
-
-
-;;; {Running Repls}
-;;;
-
-(define (repl read evaler print)
-  (let loop ((source (read (current-input-port))))
-    (print (evaler source))
-    (loop (read (current-input-port)))))
-
-;; A provisional repl that acts like the SCM repl:
-;;
-(define scm-repl-silent #f)
-(define (assert-repl-silence v) (set! scm-repl-silent v))
-
-(define *unspecified* (if #f #f))
-(define (unspecified? v) (eq? v *unspecified*))
-
-(define scm-repl-print-unspecified #f)
-(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
-
-(define scm-repl-verbose #f)
-(define (assert-repl-verbosity v) (set! scm-repl-verbose v))
-
-(define scm-repl-prompt "guile> ")
-
-(define (set-repl-prompt! v) (set! scm-repl-prompt v))
-
-(define (default-lazy-handler key . args)
-  (save-stack lazy-handler-dispatch)
-  (apply throw key args))
-
-(define (lazy-handler-dispatch key . args)
-  (apply default-lazy-handler key args))
-
-(define abort-hook (make-hook))
-
-;; these definitions are used if running a script.
-;; otherwise redefined in error-catching-loop.
-(define (set-batch-mode?! arg) #t)
-(define (batch-mode?) #t)
-
-(define (error-catching-loop thunk)
-  (let ((status #f)
-	(interactive #t))
-    (define (loop first)
-      (let ((next
-	     (catch #t
-
-		    (lambda ()
-		      (lazy-catch #t
-				  (lambda ()
-				    (dynamic-wind
-				     (lambda () (unmask-signals))
-				     (lambda ()
-				       (with-traps
-					(lambda ()
-					  (first)
-
-					  ;; This line is needed because mark
-					  ;; doesn't do closures quite right.
-					  ;; Unreferenced locals should be
-					  ;; collected.
-					  ;;
-					  (set! first #f)
-					  (let loop ((v (thunk)))
-					    (loop (thunk)))
-					  #f)))
-				     (lambda () (mask-signals))))
-
-				  lazy-handler-dispatch))
-
-		    (lambda (key . args)
-		      (case key
-			((quit)
-			 (set! status args)
-			 #f)
-
-			((switch-repl)
-			 (apply throw 'switch-repl args))
-
-			((abort)
-			 ;; This is one of the closures that require
-			 ;; (set! first #f) above
-			 ;;
-			 (lambda ()
-			   (run-hook abort-hook)
-			   (force-output (current-output-port))
-			   (display "ABORT: "  (current-error-port))
-			   (write args (current-error-port))
-			   (newline (current-error-port))
-			   (if interactive
-			       (begin
-				 (if (and
-				      (not has-shown-debugger-hint?)
-				      (not (memq 'backtrace
-						 (debug-options-interface)))
-				      (stack? (fluid-ref the-last-stack)))
-				     (begin
-				       (newline (current-error-port))
-				       (display
-					"Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n"
-					(current-error-port))
-				       (set! has-shown-debugger-hint? #t)))
-				 (force-output (current-error-port)))
-			       (begin
-				 (primitive-exit 1)))
-			   (set! stack-saved? #f)))
-
-			(else
-			 ;; This is the other cons-leak closure...
-			 (lambda ()
-			   (cond ((= (length args) 4)
-				  (apply handle-system-error key args))
-				 (else
-				  (apply bad-throw key args))))))))))
-	(if next (loop next) status)))
-    (set! set-batch-mode?! (lambda (arg)
-			     (cond (arg
-				    (set! interactive #f)
-				    (restore-signals))
-				   (#t
-				    (error "sorry, not implemented")))))
-    (set! batch-mode? (lambda () (not interactive)))
-    (loop (lambda () #t))))
-
-;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
-(define before-signal-stack (make-fluid))
-(define stack-saved? #f)
-
-(define (save-stack . narrowing)
-  (or stack-saved?
-      (cond ((not (memq 'debug (debug-options-interface)))
-	     (fluid-set! the-last-stack #f)
-	     (set! stack-saved? #t))
-	    (else
-	     (fluid-set!
-	      the-last-stack
-	      (case (stack-id #t)
-		((repl-stack)
-		 (apply make-stack #t save-stack primitive-eval #t 0 narrowing))
-		((load-stack)
-		 (apply make-stack #t save-stack 0 #t 0 narrowing))
-		((tk-stack)
-		 (apply make-stack #t save-stack tk-stack-mark #t 0 narrowing))
-		((#t)
-		 (apply make-stack #t save-stack 0 1 narrowing))
-		(else
-		 (let ((id (stack-id #t)))
-		   (and (procedure? id)
-			(apply make-stack #t save-stack id #t 0 narrowing))))))
-	     (set! stack-saved? #t)))))
-
-(define before-error-hook (make-hook))
-(define after-error-hook (make-hook))
-(define before-backtrace-hook (make-hook))
-(define after-backtrace-hook (make-hook))
-
-(define has-shown-debugger-hint? #f)
-
-(define (handle-system-error key . args)
-  (let ((cep (current-error-port)))
-    (cond ((not (stack? (fluid-ref the-last-stack))))
-	  ((memq 'backtrace (debug-options-interface))
-	   (run-hook before-backtrace-hook)
-	   (newline cep)
-	   (display "Backtrace:\n")
-	   (display-backtrace (fluid-ref the-last-stack) cep)
-	   (newline cep)
-	   (run-hook after-backtrace-hook)))
-    (run-hook before-error-hook)
-    (apply display-error (fluid-ref the-last-stack) cep args)
-    (run-hook after-error-hook)
-    (force-output cep)
-    (throw 'abort key)))
-
-(define (quit . args)
-  (apply throw 'quit args))
-
-(define exit quit)
-
-;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
-
-;; Replaced by C code:
-;;(define (backtrace)
-;;  (if (fluid-ref the-last-stack)
-;;      (begin
-;;	(newline)
-;;	(display-backtrace (fluid-ref the-last-stack) (current-output-port))
-;;	(newline)
-;;	(if (and (not has-shown-backtrace-hint?)
-;;		 (not (memq 'backtrace (debug-options-interface))))
-;;	    (begin
-;;	      (display
-;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
-;;automatically if an error occurs in the future.\n")
-;;	      (set! has-shown-backtrace-hint? #t))))
-;;      (display "No backtrace available.\n")))
-
-(define (error-catching-repl r e p)
-  (error-catching-loop
-   (lambda ()
-     (call-with-values (lambda () (e (r)))
-       (lambda the-values (for-each p the-values))))))
-
-(define (gc-run-time)
-  (cdr (assq 'gc-time-taken (gc-stats))))
-
-(define before-read-hook (make-hook))
-(define after-read-hook (make-hook))
-(define before-eval-hook (make-hook 1))
-(define after-eval-hook (make-hook 1))
-(define before-print-hook (make-hook 1))
-(define after-print-hook (make-hook 1))
-
-;;; The default repl-reader function.  We may override this if we've
-;;; the readline library.
-(define repl-reader
-  (lambda (prompt)
-    (display prompt)
-    (force-output)
-    (run-hook before-read-hook)
-    (read (current-input-port))))
-
-(define (scm-style-repl)
-
-  (letrec (
-	   (start-gc-rt #f)
-	   (start-rt #f)
-	   (repl-report-start-timing (lambda ()
-				       (set! start-gc-rt (gc-run-time))
-				       (set! start-rt (get-internal-run-time))))
-	   (repl-report (lambda ()
-			  (display ";;; ")
-			  (display (inexact->exact
-				    (* 1000 (/ (- (get-internal-run-time) start-rt)
-					       internal-time-units-per-second))))
-			  (display "  msec  (")
-			  (display  (inexact->exact
-				     (* 1000 (/ (- (gc-run-time) start-gc-rt)
-						internal-time-units-per-second))))
-			  (display " msec in gc)\n")))
-
-	   (consume-trailing-whitespace
-	    (lambda ()
-	      (let ((ch (peek-char)))
-		(cond
-		 ((eof-object? ch))
-		 ((or (char=? ch #\space) (char=? ch #\tab))
-		  (read-char)
-		  (consume-trailing-whitespace))
-		 ((char=? ch #\newline)
-		  (read-char))))))
-	   (-read (lambda ()
-		    (let ((val
-			   (let ((prompt (cond ((string? scm-repl-prompt)
-						scm-repl-prompt)
-					       ((thunk? scm-repl-prompt)
-						(scm-repl-prompt))
-					       (scm-repl-prompt "> ")
-					       (else ""))))
-			     (repl-reader prompt))))
-
-		      ;; As described in R4RS, the READ procedure updates the
-		      ;; port to point to the first character past the end of
-		      ;; the external representation of the object.  This
-		      ;; means that it doesn't consume the newline typically
-		      ;; found after an expression.  This means that, when
-		      ;; debugging Guile with GDB, GDB gets the newline, which
-		      ;; it often interprets as a "continue" command, making
-		      ;; breakpoints kind of useless.  So, consume any
-		      ;; trailing newline here, as well as any whitespace
-		      ;; before it.
-		      ;; But not if EOF, for control-D.
-		      (if (not (eof-object? val))
-			  (consume-trailing-whitespace))
-		      (run-hook after-read-hook)
-		      (if (eof-object? val)
-			  (begin
-			    (repl-report-start-timing)
-			    (if scm-repl-verbose
-				(begin
-				  (newline)
-				  (display ";;; EOF -- quitting")
-				  (newline)))
-			    (quit 0)))
-		      val)))
-
-	   (-eval (lambda (sourc)
-		    (repl-report-start-timing)
-		    (run-hook before-eval-hook sourc)
-		    (let ((val (start-stack 'repl-stack
-					    ;; If you change this procedure
-					    ;; (primitive-eval), please also
-					    ;; modify the repl-stack case in
-					    ;; save-stack so that stack cutting
-					    ;; continues to work.
-					    (primitive-eval sourc))))
-		      (run-hook after-eval-hook sourc)
-		      val)))
-
-
-	   (-print (let ((maybe-print (lambda (result)
-					(if (or scm-repl-print-unspecified
-						(not (unspecified? result)))
-					    (begin
-					      (write result)
-					      (newline))))))
-		     (lambda (result)
-		       (if (not scm-repl-silent)
-			   (begin
-			     (run-hook before-print-hook result)
-			     (maybe-print result)
-			     (run-hook after-print-hook result)
-			     (if scm-repl-verbose
-				 (repl-report))
-			     (force-output))))))
-
-	   (-quit (lambda (args)
-		    (if scm-repl-verbose
-			(begin
-			  (display ";;; QUIT executed, repl exitting")
-			  (newline)
-			  (repl-report)))
-		    args))
-
-	   (-abort (lambda ()
-		     (if scm-repl-verbose
-			 (begin
-			   (display ";;; ABORT executed.")
-			   (newline)
-			   (repl-report)))
-		     (repl -read -eval -print))))
-
-    (let ((status (error-catching-repl -read
-				       -eval
-				       -print)))
-      (-quit status))))
-
-
-
-;;; {IOTA functions: generating lists of numbers}
-
-(define (iota n)
-  (let loop ((count (1- n)) (result '()))
-    (if (< count 0) result
-        (loop (1- count) (cons count result)))))
-
-
-;;; {While}
-;;;
-;;; with `continue' and `break'.
-;;;
-
-(defmacro while (cond . body)
-  `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue)))))
-	    (break (lambda val (apply throw 'break val))))
-     (catch 'break
-	    (lambda () (continue))
-	    (lambda v (cadr v)))))
-
-;;; {collect}
-;;;
-;;; Similar to `begin' but returns a list of the results of all constituent
-;;; forms instead of the result of the last form.
-;;; (The definition relies on the current left-to-right
-;;;  order of evaluation of operands in applications.)
-
-(defmacro collect forms
-  (cons 'list forms))
-
-;;; {with-fluids}
-
-;; with-fluids is a convenience wrapper for the builtin procedure
-;; `with-fluids*'.  The syntax is just like `let':
-;;
-;;  (with-fluids ((fluid val)
-;;                ...)
-;;     body)
-
-(defmacro with-fluids (bindings . body)
-  `(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
-		 (lambda () ,@body)))
-
-
-
-;;; {Macros}
-;;;
-
-;; actually....hobbit might be able to hack these with a little
-;; coaxing
-;;
-
-(defmacro define-macro (first . rest)
-  (let ((name (if (symbol? first) first (car first)))
-	(transformer
-	 (if (symbol? first)
-	     (car rest)
-	     `(lambda ,(cdr first) ,@rest))))
-    `(eval-case
-      ((load-toplevel)
-       (define ,name (defmacro:transformer ,transformer)))
-      (else
-       (error "define-macro can only be used at the top level")))))
-
-
-(defmacro define-syntax-macro (first . rest)
-  (let ((name (if (symbol? first) first (car first)))
-	(transformer
-	 (if (symbol? first)
-	     (car rest)
-	     `(lambda ,(cdr first) ,@rest))))
-    `(eval-case
-      ((load-toplevel)
-       (define ,name (defmacro:syntax-transformer ,transformer)))
-      (else
-       (error "define-syntax-macro can only be used at the top level")))))
-
-
-;;; {Module System Macros}
-;;;
-
-;; Return a list of expressions that evaluate to the appropriate
-;; arguments for resolve-interface according to SPEC.
-
-(define (compile-interface-spec spec)
-  (define (make-keyarg sym key quote?)
-    (cond ((or (memq sym spec)
-	       (memq key spec))
-	   => (lambda (rest)
-		(if quote?
-		    (list key (list 'quote (cadr rest)))
-		    (list key (cadr rest)))))
-	  (else
-	   '())))
-  (define (map-apply func list)
-    (map (lambda (args) (apply func args)) list))
-  (define keys
-    ;; sym     key      quote?
-    '((:select #:select #t)
-      (:renamer #:renamer #f)))
-  (if (not (pair? (car spec)))
-      `(',spec)
-      `(',(car spec)
-	,@(apply append (map-apply make-keyarg keys)))))
-
-(define (keyword-like-symbol->keyword sym)
-  (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
-
-(define (compile-define-module-args args)
-  ;; Just quote everything except #:use-module and #:use-syntax.  We
-  ;; need to know about all arguments regardless since we want to turn
-  ;; symbols that look like keywords into real keywords, and the
-  ;; keyword args in a define-module form are not regular
-  ;; (i.e. no-backtrace doesn't take a value).
-  (let loop ((compiled-args `((quote ,(car args))))
-	     (args (cdr args)))
-    (cond ((null? args)
-	   (reverse! compiled-args))
-	  ;; symbol in keyword position
-	  ((symbol? (car args))
-	   (loop compiled-args
-		 (cons (keyword-like-symbol->keyword (car args)) (cdr args))))
-	  ((memq (car args) '(#:no-backtrace #:pure))
-	   (loop (cons (car args) compiled-args)
-		 (cdr args)))
-	  ((null? (cdr args))
-	   (error "keyword without value:" (car args)))
-	  ((memq (car args) '(#:use-module #:use-syntax))
-	   (loop (cons* `(list ,@(compile-interface-spec (cadr args)))
-			(car args)
-			compiled-args)
-		 (cddr args)))
-	  ((eq? (car args) #:autoload)
-	   (loop (cons* `(quote ,(caddr args))
-			`(quote ,(cadr args))
-			(car args)
-			compiled-args)
-		 (cdddr args)))
-	  (else
-	   (loop (cons* `(quote ,(cadr args))
-			(car args)
-			compiled-args)
-		 (cddr args))))))
-
-(defmacro define-module args
-  `(eval-case
-    ((load-toplevel)
-     (let ((m (process-define-module
-	       (list ,@(compile-define-module-args args)))))
-       (set-current-module m)
-       m))
-    (else
-     (error "define-module can only be used at the top level"))))
-
-;; The guts of the use-modules macro.  Add the interfaces of the named
-;; modules to the use-list of the current module, in order.
-
-(define (process-use-modules module-interface-args)
-  (for-each (lambda (mif-args)
-	      (let ((mod-iface (apply resolve-interface mif-args)))
-		(or mod-iface
-		    (error "no such module" mif-args))
-		(module-use! (current-module) mod-iface)))
-	    module-interface-args))
-
-(defmacro use-modules modules
-  `(eval-case
-    ((load-toplevel)
-     (process-use-modules
-      (list ,@(map (lambda (m)
-		     `(list ,@(compile-interface-spec m)))
-		   modules))))
-    (else
-     (error "use-modules can only be used at the top level"))))
-
-(defmacro use-syntax (spec)
-  `(eval-case
-    ((load-toplevel)
-     ,@(if (pair? spec)
-	   `((process-use-modules (list
-				   (list ,@(compile-interface-spec spec))))
-	     (set-module-transformer! (current-module)
-				      ,(car (last-pair spec))))
-	   `((set-module-transformer! (current-module) ,spec)))
-     (fluid-set! scm:eval-transformer (module-transformer (current-module)))
-     *unspecified*)
-    (else
-     (error "use-syntax can only be used at the top level"))))
-
-(define define-private define)
-
-(defmacro define-public args
-  (define (syntax)
-    (error "bad syntax" (list 'define-public args)))
-  (define (defined-name n)
-    (cond
-     ((symbol? n) n)
-     ((pair? n) (defined-name (car n)))
-     (else (syntax))))
-  (cond
-   ((null? args)
-    (syntax))
-   (#t
-    (let ((name (defined-name (car args))))
-      `(begin
-	 (define-private ,@args)
-	 (eval-case ((load-toplevel) (export ,name))))))))
-
-(defmacro defmacro-public args
-  (define (syntax)
-    (error "bad syntax" (list 'defmacro-public args)))
-  (define (defined-name n)
-    (cond
-     ((symbol? n) n)
-     (else (syntax))))
-  (cond
-   ((null? args)
-    (syntax))
-   (#t
-    (let ((name (defined-name (car args))))
-      `(begin
-	 (eval-case ((load-toplevel) (export ,name)))
-	 (defmacro ,@args))))))
-
-;; Export a local variable
-
-;; This function is called from "modules.c".  If you change it, be
-;; sure to update "modules.c" as well.
-
-(define (module-export! m names)
-  (let ((public-i (module-public-interface m)))
-    (for-each (lambda (name)
-		(begin-deprecated
-		 (if (not (module-local-variable m name))
-		     (let ((v (module-variable m name)))
-		       (cond
-			(v
-			 (issue-deprecation-warning
-			  "Using `export' to re-export imported bindings is deprecated.  Use `re-export' instead.")
-			 (issue-deprecation-warning
-			  (simple-format #f "(You just re-exported `~a' from `~a'.)"
-					 name (module-name m)))
-			 (module-define! m name (variable-ref v)))))))
-		(let ((var (module-ensure-local-variable! m name)))
-		  (module-add! public-i name var)))
-	      names)))
-
-;; Re-export a imported variable
-;;
-(define (module-re-export! m names)
-  (let ((public-i (module-public-interface m)))
-    (for-each (lambda (name)
-		(let ((var (module-variable m name)))
-		  (cond ((not var)
-			 (error "Undefined variable:" name))
-			((eq? var (module-local-variable m name))
-			 (error "re-exporting local variable:" name))
-			(else
-			 (module-add! public-i name var)))))
-	      names)))
-
-(defmacro export names
-  `(eval-case
-    ((load-toplevel)
-     (module-export! (current-module) ',names))
-    (else
-     (error "export can only be used at the top level"))))
-
-(defmacro re-export names
-  `(eval-case
-    ((load-toplevel)
-     (module-re-export! (current-module) ',names))
-    (else
-     (error "re-export can only be used at the top level"))))
-
-(define export-syntax export)
-(define re-export-syntax re-export)
-
-
-(define load load-module)
-
-
-
-;;; {`cond-expand' for SRFI-0 support.}
-;;;
-;;; This syntactic form expands into different commands or
-;;; definitions, depending on the features provided by the Scheme
-;;; implementation.
-;;;
-;;; Syntax:
-;;;
-;;; <cond-expand>
-;;;   --> (cond-expand <cond-expand-clause>+)
-;;;     | (cond-expand <cond-expand-clause>* (else <command-or-definition>))
-;;; <cond-expand-clause>
-;;;   --> (<feature-requirement> <command-or-definition>*)
-;;; <feature-requirement>
-;;;   --> <feature-identifier>
-;;;     | (and <feature-requirement>*)
-;;;     | (or <feature-requirement>*)
-;;;     | (not <feature-requirement>)
-;;; <feature-identifier>
-;;;   --> <a symbol which is the name or alias of a SRFI>
-;;;
-;;; Additionally, this implementation provides the
-;;; <feature-identifier>s `guile' and `r5rs', so that programs can
-;;; determine the implementation type and the supported standard.
-;;;
-;;; Currently, the following feature identifiers are supported:
-;;;
-;;;   guile r5rs srfi-0 srfi-6
-;;;
-;;; Remember to update the features list when adding more SRFIs.
-
-(define %cond-expand-features
-  ;; Adjust the above comment when changing this.
-  '(guile
-    r5rs
-    srfi-0   ;; cond-expand itself
-    srfi-6   ;; open-input-string etc, in the guile core
-    ))
-
-;; This table maps module public interfaces to the list of features.
-;;
-(define %cond-expand-table (make-hash-table 31))
-
-;; Add one or more features to the `cond-expand' feature list of the
-;; module `module'.
-;;
-(define (cond-expand-provide module features)
-  (let ((mod (module-public-interface module)))
-    (and mod
-	 (hashq-set! %cond-expand-table mod
-		     (append (hashq-ref %cond-expand-table mod '())
-			     features)))))
-
-(define cond-expand
-  (procedure->memoizing-macro
-   (lambda (exp env)
-     (let ((clauses (cdr exp))
-	   (syntax-error (lambda (cl)
-			   (error "invalid clause in `cond-expand'" cl))))
-       (letrec
-	   ((test-clause
-	     (lambda (clause)
-	       (cond
-		((symbol? clause)
-		 (or (memq clause %cond-expand-features)
-		     (let lp ((uses (module-uses (env-module env))))
-		       (if (pair? uses)
-			   (or (memq clause
-				     (hashq-ref %cond-expand-table
-						(car uses) '()))
-			       (lp (cdr uses)))
-			   #f))))
-		((pair? clause)
-		 (cond
-		  ((eq? 'and (car clause))
-		   (let lp ((l (cdr clause)))
-		     (cond ((null? l)
-			    #t)
-			   ((pair? l)
-			    (and (test-clause (car l)) (lp (cdr l))))
-			   (else
-			    (syntax-error clause)))))
-		  ((eq? 'or (car clause))
-		   (let lp ((l (cdr clause)))
-		     (cond ((null? l)
-			    #f)
-			   ((pair? l)
-			    (or (test-clause (car l)) (lp (cdr l))))
-			   (else
-			    (syntax-error clause)))))
-		  ((eq? 'not (car clause))
-		   (cond ((not (pair? (cdr clause)))
-			  (syntax-error clause))
-			 ((pair? (cddr clause))
-			  ((syntax-error clause))))
-		   (not (test-clause (cadr clause))))
-		  (else
-		   (syntax-error clause))))
-		(else
-		 (syntax-error clause))))))
-	 (let lp ((c clauses))
-	   (cond
-	    ((null? c)
-	     (error "Unfulfilled `cond-expand'"))
-	    ((not (pair? c))
-	     (syntax-error c))
-	    ((not (pair? (car c)))
-	     (syntax-error (car c)))
-	    ((test-clause (caar c))
-	     `(begin ,@(cdar c)))
-	    ((eq? (caar c) 'else)
-	     (if (pair? (cdr c))
-		 (syntax-error c))
-	     `(begin ,@(cdar c)))
-	    (else
-	     (lp (cdr c))))))))))
-
-;; This procedure gets called from the startup code with a list of
-;; numbers, which are the numbers of the SRFIs to be loaded on startup.
-;;
-(define (use-srfis srfis)
-  (let lp ((s srfis))
-    (if (pair? s)
-        (let* ((srfi (string->symbol
-                      (string-append "srfi-" (number->string (car s)))))
-               (mod-i (resolve-interface (list 'srfi srfi))))
-          (module-use! (current-module) mod-i)
-          (lp (cdr s))))))
-
-
-
-;;; {Load emacs interface support if emacs option is given.}
-
-(define (named-module-use! user usee)
-  (module-use! (resolve-module user) (resolve-interface usee)))
-
-(define (load-emacs-interface)
-  (and (provided? 'debug-extensions)
-       (debug-enable 'backtrace))
-  (named-module-use! '(guile-user) '(ice-9 emacs)))
-
-
-
-(define using-readline?
-  (let ((using-readline? (make-fluid)))
-     (make-procedure-with-setter
-      (lambda () (fluid-ref using-readline?))
-      (lambda (v) (fluid-set! using-readline? v)))))
-
-(define (top-repl)
-  (let ((guile-user-module (resolve-module '(guile-user))))
-
-    ;; Load emacs interface support if emacs option is given.
-    (if (and (module-defined? guile-user-module 'use-emacs-interface)
-	     (module-ref guile-user-module 'use-emacs-interface))
-	(load-emacs-interface))
-
-    ;; Use some convenient modules (in reverse order)
-
-    (if (provided? 'regex)
-	(module-use! guile-user-module (resolve-interface '(ice-9 regex))))
-    (if (provided? 'threads)
-	(module-use! guile-user-module (resolve-interface '(ice-9 threads))))
-    ;; load debugger on demand
-    (module-use! guile-user-module
-		 (make-autoload-interface guile-user-module
-					  '(ice-9 debugger) '(debug)))
-    (module-use! guile-user-module (resolve-interface '(ice-9 session)))
-    (module-use! guile-user-module (resolve-interface '(ice-9 debug)))
-    ;; so that builtin bindings will be checked first
-    (module-use! guile-user-module (resolve-interface '(guile)))
-
-    (set-current-module guile-user-module)
-
-    (let ((old-handlers #f)
-	  (signals (if (provided? 'posix)
-		       `((,SIGINT . "User interrupt")
-			 (,SIGFPE . "Arithmetic error")
-			 (,SIGBUS . "Bad memory access (bus error)")
-			 (,SIGSEGV
-			  . "Bad memory access (Segmentation violation)"))
-		       '())))
-
-      (dynamic-wind
-
-	  ;; call at entry
-	  (lambda ()
-	    (let ((make-handler (lambda (msg)
-				  (lambda (sig)
-				    ;; Make a backup copy of the stack
-				    (fluid-set! before-signal-stack
-						(fluid-ref the-last-stack))
-				    (save-stack %deliver-signals)
-				    (scm-error 'signal
-					       #f
-					       msg
-					       #f
-					       (list sig))))))
-	      (set! old-handlers
-		    (map (lambda (sig-msg)
-			   (sigaction (car sig-msg)
-				      (make-handler (cdr sig-msg))))
-			 signals))))
-
-	  ;; the protected thunk.
-	  (lambda ()
-	    (let ((status (scm-style-repl)))
-	      (run-hook exit-hook)
-	      status))
-
-	  ;; call at exit.
-	  (lambda ()
-	    (map (lambda (sig-msg old-handler)
-		   (if (not (car old-handler))
-		       ;; restore original C handler.
-		       (sigaction (car sig-msg) #f)
-		       ;; restore Scheme handler, SIG_IGN or SIG_DFL.
-		       (sigaction (car sig-msg)
-				  (car old-handler)
-				  (cdr old-handler))))
-		 signals old-handlers))))))
-
-(defmacro false-if-exception (expr)
-  `(catch #t (lambda () ,expr)
-	  (lambda args #f)))
-
-;;; This hook is run at the very end of an interactive session.
-;;;
-(define exit-hook (make-hook))
-
-
-(append! %load-path (list "."))
-
-;; Place the user in the guile-user module.
-;;
-
-(define-module (guile-user))
-
-(begin-deprecated
- ;; automatic availability of this module is deprecated.
- (use-modules (ice-9 rdelim)))
-
 ;;; boot-9.scm ends here

tests/examplefiles/example.c

     return result;
 }
 
-/*
- *  call-seq:
- *     array.delete(obj)            -> obj or nil 
- *     array.delete(obj) { block }  -> obj or nil
- *  
- *  Deletes items from <i>self</i> that are equal to <i>obj</i>. If
- *  the item is not found, returns <code>nil</code>. If the optional
- *  code block is given, returns the result of <i>block</i> if the item
- *  is not found.
- *     
- *     a = [ "a", "b", "b", "b", "c" ]
- *     a.delete("b")                   #=> "b"
- *     a                               #=> ["a", "c"]
- *     a.delete("z")                   #=> nil
- *     a.delete("z") { "not found" }   #=> "not found"
- */
-
-VALUE
-rb_ary_delete(ary, item)
-    VALUE ary;
-    VALUE item;
-{
-    long i1, i2;
-
-    for (i1 = i2 = 0; i1 < RARRAY(ary)->len; i1++) {
-	VALUE e = RARRAY(ary)->ptr[i1];
-
-	if (rb_equal(e, item)) continue;
-	if (i1 != i2) {
-	    rb_ary_store(ary, i2, e);
-	}
-	i2++;
-    }
-    if (RARRAY(ary)->len == i2) {
-	if (rb_block_given_p()) {
-	    return rb_yield(item);
-	}
-	return Qnil;
-    }
-
-    rb_ary_modify(ary);
-    if (RARRAY(ary)->len > i2) {
-	RARRAY(ary)->len = i2;
-	if (i2 * 2 < RARRAY(ary)->aux.capa &&
-	    RARRAY(ary)->aux.capa > ARY_DEFAULT_SIZE) {
-	    REALLOC_N(RARRAY(ary)->ptr, VALUE, i2 * 2);
-	    RARRAY(ary)->aux.capa = i2 * 2;
-	}
-    }
-
-    return item;
-}
-
-VALUE
-rb_ary_delete_at(ary, pos)
-    VALUE ary;
-    long pos;
-{
-    long i, len = RARRAY(ary)->len;
-    VALUE del;
-
-    if (pos >= len) return Qnil;
-    if (pos < 0) {
-	pos += len;
-	if (pos < 0) return Qnil;
-    }
-
-    rb_ary_modify(ary);
-    del = RARRAY(ary)->ptr[pos];
-    for (i = pos + 1; i < len; i++, pos++) {
-	RARRAY(ary)->ptr[pos] = RARRAY(ary)->ptr[i];
-    }
-    RARRAY(ary)->len = pos;
-
-    return del;
-}
-
-/*
- *  call-seq:
- *     array.delete_at(index)  -> obj or nil
- *  
- *  Deletes the element at the specified index, returning that element,
- *  or <code>nil</code> if the index is out of range. See also
- *  <code>Array#slice!</code>.
- *     
- *     a = %w( ant bat cat dog )
- *     a.delete_at(2)    #=> "cat"
- *     a                 #=> ["ant", "bat", "dog"]
- *     a.delete_at(99)   #=> nil
- */
-
-static VALUE
-rb_ary_delete_at_m(ary, pos)
-    VALUE ary, pos;
-{
-    return rb_ary_delete_at(ary, NUM2LONG(pos));
-}
-
-/*
- *  call-seq:
- *     array.slice!(index)         -> obj or nil
- *     array.slice!(start, length) -> sub_array or nil
- *     array.slice!(range)         -> sub_array or nil 
- *  
- *  Deletes the element(s) given by an index (optionally with a length)
- *  or by a range. Returns the deleted object, subarray, or
- *  <code>nil</code> if the index is out of range. Equivalent to:
- *     
- *     def slice!(*args)
- *       result = self[*args]
- *       self[*args] = nil
- *       result
- *     end
- *     
- *     a = [ "a", "b", "c" ]
- *     a.slice!(1)     #=> "b"
- *     a               #=> ["a", "c"]
- *     a.slice!(-1)    #=> "c"
- *     a               #=> ["a"]
- *     a.slice!(100)   #=> nil
- *     a               #=> ["a"]
- */
-
-static VALUE
-rb_ary_slice_bang(argc, argv, ary)
-    int argc;
-    VALUE *argv;
-    VALUE ary;
-{
-    VALUE arg1, arg2;
-    long pos, len;
-
-    if (rb_scan_args(argc, argv, "11", &arg1, &arg2) == 2) {
-	pos = NUM2LONG(arg1);
-	len = NUM2LONG(arg2);
-      delete_pos_len:
-	if (pos < 0) {
-	    pos = RARRAY(ary)->len + pos;
-	}
-	arg2 = rb_ary_subseq(ary, pos, len);
-	rb_ary_splice(ary, pos, len, Qundef);	/* Qnil/rb_ary_new2(0) */
-	return arg2;
-    }
-
-    if (!FIXNUM_P(arg1) && rb_range_beg_len(arg1, &pos, &len, RARRAY(ary)->len, 1)) {
-	goto delete_pos_len;
-    }
-
-    return rb_ary_delete_at(ary, NUM2LONG(arg1));
-}
-
-/*
- *  call-seq:
- *     array.reject! {|item| block }  -> array or nil
- *  
- *  Equivalent to <code>Array#delete_if</code>, deleting elements from
- *  _self_ for which the block evaluates to true, but returns
- *  <code>nil</code> if no changes were made. Also see
- *  <code>Enumerable#reject</code>.
- */
-
-static VALUE
-rb_ary_reject_bang(ary)
-    VALUE ary;
-{
-    long i1, i2;
-
-    rb_ary_modify(ary);
-    for (i1 = i2 = 0; i1 < RARRAY(ary)->len; i1++) {
-	VALUE v = RARRAY(ary)->ptr[i1];
-	if (RTEST(rb_yield(v))) continue;
-	if (i1 != i2) {
-	    rb_ary_store(ary, i2, v);
-	}
-	i2++;
-    }
-    if (RARRAY(ary)->len == i2) return Qnil;
-    if (i2 < RARRAY(ary)->len)
-	RARRAY(ary)->len = i2;
-
-    return ary;
-}
-
-/*
- *  call-seq:
- *     array.reject {|item| block }  -> an_array
- *  
- *  Returns a new array containing the items in _self_
- *  for which the block is not true.
- */
-
-static VALUE
-rb_ary_reject(ary)
-    VALUE ary;
-{
-    ary = rb_ary_dup(ary);
-    rb_ary_reject_bang(ary);
-    return ary;
-}
-
-/*
- *  call-seq:
- *     array.delete_if {|item| block }  -> array
- *  
- *  Deletes every element of <i>self</i> for which <i>block</i> evaluates
- *  to <code>true</code>.
- *     
- *     a = [ "a", "b", "c" ]
- *     a.delete_if {|x| x >= "b" }   #=> ["a"]
- */
-
-static VALUE
-rb_ary_delete_if(ary)
-    VALUE ary;
-{
-    rb_ary_reject_bang(ary);
-    return ary;
-}
-
-/*
- *  call-seq:
- *     array.zip(arg, ...)                   -> an_array
- *     array.zip(arg, ...) {| arr | block }  -> nil
- *  
- *  Converts any arguments to arrays, then merges elements of
- *  <i>self</i> with corresponding elements from each argument. This
- *  generates a sequence of <code>self.size</code> <em>n</em>-element
- *  arrays, where <em>n</em> is one more that the count of arguments. If
- *  the size of any argument is less than <code>enumObj.size</code>,
- *  <code>nil</code> values are supplied. If a block given, it is
- *  invoked for each output array, otherwise an array of arrays is
- *  returned.
- *     
- *     a = [ 4, 5, 6 ]
- *     b = [ 7, 8, 9 ]
- *     
- *     [1,2,3].zip(a, b)      #=> [[1, 4, 7], [2, 5, 8], [3, 6, 9]]
- *     [1,2].zip(a,b)         #=> [[1, 4, 7], [2, 5, 8]]
- *     a.zip([1,2],[8])       #=> [[4,1,8], [5,2,nil], [6,nil,nil]]
- */
-
-static VALUE
-rb_ary_zip(argc, argv, ary)
-    int argc;
-    VALUE *argv;
-    VALUE ary;
-{
-    int i, j;
-    long len;
-    VALUE result;
-
-    for (i=0; i<argc; i++) {
-	argv[i] = to_a(argv[i]);
-    }
-    if (rb_block_given_p()) {
-	for (i=0; i<RARRAY(ary)->len; i++) {
-	    VALUE tmp = rb_ary_new2(argc+1);
-
-	    rb_ary_push(tmp, rb_ary_elt(ary, i));
-	    for (j=0; j<argc; j++) {
-		rb_ary_push(tmp, rb_ary_elt(argv[j], i));
-	    }
-	    rb_yield(tmp);
-	}
-	return Qnil;
-    }
-    len = RARRAY(ary)->len;
-    result = rb_ary_new2(len);
-    for (i=0; i<len; i++) {
-	VALUE tmp = rb_ary_new2(argc+1);
-
-	rb_ary_push(tmp, rb_ary_elt(ary, i));
-	for (j=0; j<argc; j++) {
-	    rb_ary_push(tmp, rb_ary_elt(argv[j], i));
-	}
-	rb_ary_push(result, tmp);
-    }
-    return result;
-}
-
-/*
- *  call-seq:
- *     array.transpose -> an_array
- *  
- *  Assumes that <i>self</i> is an array of arrays and transposes the
- *  rows and columns.
- *     
- *     a = [[1,2], [3,4], [5,6]]
- *     a.transpose   #=> [[1, 3, 5], [2, 4, 6]]
- */
-
-static VALUE
-rb_ary_transpose(ary)
-    VALUE ary;
-{
-    long elen = -1, alen, i, j;
-    VALUE tmp, result = 0;
-
-    alen = RARRAY(ary)->len;
-    if (alen == 0) return rb_ary_dup(ary);
-    for (i=0; i<alen; i++) {
-	tmp = to_ary(rb_ary_elt(ary, i));
-	if (elen < 0) {		/* first element */
-	    elen = RARRAY(tmp)->len;
-	    result = rb_ary_new2(elen);
-	    for (j=0; j<elen; j++) {
-		rb_ary_store(result, j, rb_ary_new2(alen));
-	    }
-	}
-	else if (elen != RARRAY(tmp)->len) {
-	    rb_raise(rb_eIndexError, "element size differs (%d should be %d)",
-		     RARRAY(tmp)->len, elen);
-	}
-	for (j=0; j<elen; j++) {
-	    rb_ary_store(rb_ary_elt(result, j), i, rb_ary_elt(tmp, j));
-	}
-    }
-    return result;
-}
-
-/*
- *  call-seq:
- *     array.replace(other_array)  -> array
- *  
- *  Replaces the contents of <i>self</i> with the contents of
- *  <i>other_array</i>, truncating or expanding if necessary.
- *     
- *     a = [ "a", "b", "c", "d", "e" ]
- *     a.replace([ "x", "y", "z" ])   #=> ["x", "y", "z"]
- *     a                              #=> ["x", "y", "z"]
- */
-
-static VALUE
-rb_ary_replace(copy, orig)
-    VALUE copy, orig;
-{
-    VALUE shared;
-
-    rb_ary_modify(copy);
-    orig = to_ary(orig);
-    if (copy == orig) return copy;
-    shared = ary_make_shared(orig);
-    if (RARRAY(copy)->ptr && !FL_TEST(copy, ELTS_SHARED))
-	free(RARRAY(copy)->ptr);
-    RARRAY(copy)->ptr = RARRAY(orig)->ptr;
-    RARRAY(copy)->len = RARRAY(orig)->len;
-    RARRAY(copy)->aux.shared = shared;
-    FL_SET(copy, ELTS_SHARED);
-
-    return copy;
-}
-
-/* 
- *  call-seq:
- *     array.clear    ->  array
- *
- *  Removes all elements from _self_.
- *
- *     a = [ "a", "b", "c", "d", "e" ]
- *     a.clear    #=> [ ]
- */
-
-VALUE
-rb_ary_clear(ary)
-    VALUE ary;
-{
-    rb_ary_modify(ary);
-    RARRAY(ary)->len = 0;
-    if (ARY_DEFAULT_SIZE * 2 < RARRAY(ary)->aux.capa) {
-	REALLOC_N(RARRAY(ary)->ptr, VALUE, ARY_DEFAULT_SIZE * 2);
-	RARRAY(ary)->aux.capa = ARY_DEFAULT_SIZE * 2;
-    }
-    return ary;
-}
-
-/*
- *  call-seq:
- *     array.fill(obj)                                -> array
- *     array.fill(obj, start [, length])              -> array
- *     array.fill(obj, range )                        -> array
- *     array.fill {|index| block }                    -> array
- *     array.fill(start [, length] ) {|index| block } -> array
- *     array.fill(range) {|index| block }             -> array
- *  
- *  The first three forms set the selected elements of <i>self</i> (which
- *  may be the entire array) to <i>obj</i>. A <i>start</i> of
- *  <code>nil</code> is equivalent to zero. A <i>length</i> of
- *  <code>nil</code> is equivalent to <i>self.length</i>. The last three
- *  forms fill the array with the value of the block. The block is
- *  passed the absolute index of each element to be filled.
- *     
- *     a = [ "a", "b", "c", "d" ]
- *     a.fill("x")              #=> ["x", "x", "x", "x"]
- *     a.fill("z", 2, 2)        #=> ["x", "x", "z", "z"]
- *     a.fill("y", 0..1)        #=> ["y", "y", "z", "z"]
- *     a.fill {|i| i*i}         #=> [0, 1, 4, 9]
- *     a.fill(-2) {|i| i*i*i}   #=> [0, 1, 8, 27]
- */
-
-static VALUE
-rb_ary_fill(argc, argv, ary)
-    int argc;
-    VALUE *argv;
-    VALUE ary;
-{
-    VALUE item, arg1, arg2;
-    long beg, end, len;
-    VALUE *p, *pend;
-    int block_p = Qfalse;
-
-    if (rb_block_given_p()) {
-	block_p = Qtrue;
-	rb_scan_args(argc, argv, "02", &arg1, &arg2);
-	argc += 1;		/* hackish */
-    }
-    else {
-	rb_scan_args(argc, argv, "12", &item, &arg1, &arg2);
-    }
-    switch (argc) {
-      case 1:
-	beg = 0;
-	len = RARRAY(ary)->len;
-	break;
-      case 2:
-	if (rb_range_beg_len(arg1, &beg, &len, RARRAY(ary)->len, 1)) {
-	    break;
-	}
-	/* fall through */
-      case 3:
-	beg = NIL_P(arg1) ? 0 : NUM2LONG(arg1);
-	if (beg < 0) {
-	    beg = RARRAY(ary)->len + beg;
-	    if (beg < 0) beg = 0;
-	}
-	len = NIL_P(arg2) ? RARRAY(ary)->len - beg : NUM2LONG(arg2);
-	break;
-    }
-    rb_ary_modify(ary);
-    end = beg + len;
-    if (end > RARRAY(ary)->len) {
-	if (end >= RARRAY(ary)->aux.capa) {
-	    REALLOC_N(RARRAY(ary)->ptr, VALUE, end);
-	    RARRAY(ary)->aux.capa = end;
-	}
-	if (beg > RARRAY(ary)->len) {
-	    rb_mem_clear(RARRAY(ary)->ptr + RARRAY(ary)->len, end - RARRAY(ary)->len);
-	}
-	RARRAY(ary)->len = end;
-    }
-
-    if (block_p) {
-	VALUE v;
-	long i;
-
-	for (i=beg; i<end; i++) {
-	    v = rb_yield(LONG2NUM(i));
-	    if (i>=RARRAY(ary)->len) break;
-	    RARRAY(ary)->ptr[i] = v;
-	}
-    }
-    else {
-	p = RARRAY(ary)->ptr + beg;
-	pend = p + len;
-	while (p < pend) {
-	    *p++ = item;
-	}
-    }
-    return ary;
-}
-
-/* 
- *  call-seq:
- *     array + other_array   -> an_array
- *
- *  Concatenation---Returns a new array built by concatenating the
- *  two arrays together to produce a third array.
- * 
- *     [ 1, 2, 3 ] + [ 4, 5 ]    #=> [ 1, 2, 3, 4, 5 ]
- */
-
-VALUE
-rb_ary_plus(x, y)
-    VALUE x, y;
-{
-    VALUE z;
-    long len;
-
-    y = to_ary(y);
-    len = RARRAY(x)->len + RARRAY(y)->len;
-    z = rb_ary_new2(len);
-    MEMCPY(RARRAY(z)->ptr, RARRAY(x)->ptr, VALUE, RARRAY(x)->len);
-    MEMCPY(RARRAY(z)->ptr + RARRAY(x)->len, RARRAY(y)->ptr, VALUE, RARRAY(y)->len);
-    RARRAY(z)->len = len;
-    return z;
-}
-
-/* 
- *  call-seq:
- *     array.concat(other_array)   ->  array
- *
- *  Appends the elements in other_array to _self_.
- *  
- *     [ "a", "b" ].concat( ["c", "d"] ) #=> [ "a", "b", "c", "d" ]
- */
-
-
-VALUE
-rb_ary_concat(x, y)
-    VALUE x, y;
-{
-    y = to_ary(y);
-    if (RARRAY(y)->len > 0) {
-	rb_ary_splice(x, RARRAY(x)->len, 0, y);
-    }
-    return x;
-}
-
-
-/* 
- *  call-seq:
- *     array * int     ->    an_array
- *     array * str     ->    a_string
- *
- *  Repetition---With a String argument, equivalent to
- *  self.join(str). Otherwise, returns a new array
- *  built by concatenating the _int_ copies of _self_.
- *
- *
- *     [ 1, 2, 3 ] * 3    #=> [ 1, 2, 3, 1, 2, 3, 1, 2, 3 ]
- *     [ 1, 2, 3 ] * ","  #=> "1,2,3"
- *
- */
-
-static VALUE
-rb_ary_times(ary, times)
-    VALUE ary, times;
-{
-    VALUE ary2, tmp;
-    long i, len;
-
-    tmp = rb_check_string_type(times);
-    if (!NIL_P(tmp)) {
-	return rb_ary_join(ary, tmp);
-    }
-
-    len = NUM2LONG(times);
-    if (len == 0) return ary_new(rb_obj_class(ary), 0);
-    if (len < 0) {
-	rb_raise(rb_eArgError, "negative argument");
-    }
-    if (LONG_MAX/len < RARRAY(ary)->len) {
-	rb_raise(rb_eArgError, "argument too big");
-    }
-    len *= RARRAY(ary)->len;
-
-    ary2 = ary_new(rb_obj_class(ary), len);
-    RARRAY(ary2)->len = len;
-
-    for (i=0; i<len; i+=RARRAY(ary)->len) {
-	MEMCPY(RARRAY(ary2)->ptr+i, RARRAY(ary)->ptr, VALUE, RARRAY(ary)->len);
-    }
-    OBJ_INFECT(ary2, ary);
-
-    return ary2;
-}
-
-/* 
- *  call-seq:
- *     array.assoc(obj)   ->  an_array  or  nil
- *
- *  Searches through an array whose elements are also arrays
- *  comparing _obj_ with the first element of each contained array
- *  using obj.==.
- *  Returns the first contained array that matches (that
- *  is, the first associated array),
- *  or +nil+ if no match is found.
- *  See also <code>Array#rassoc</code>.
- *
- *     s1 = [ "colors", "red", "blue", "green" ]
- *     s2 = [ "letters", "a", "b", "c" ]
- *     s3 = "foo"
- *     a  = [ s1, s2, s3 ]
- *     a.assoc("letters")  #=> [ "letters", "a", "b", "c" ]
- *     a.assoc("foo")      #=> nil
- */
-
-VALUE
-rb_ary_assoc(ary, key)
-    VALUE ary, key;
-{
-    long i;
-    VALUE v;
-
-    for (i = 0; i < RARRAY(ary)->len; ++i) {
-	v = RARRAY(ary)->ptr[i];
-	if (TYPE(v) == T_ARRAY &&
-	    RARRAY(v)->len > 0 &&
-	    rb_equal(RARRAY(v)->ptr[0], key))
-	    return v;
-    }
-    return Qnil;
-}
-
-/*
- *  call-seq:
- *     array.rassoc(key) -> an_array or nil
- *  
- *  Searches through the array whose elements are also arrays. Compares
- *  <em>key</em> with the second element of each contained array using
- *  <code>==</code>. Returns the first contained array that matches. See
- *  also <code>Array#assoc</code>.
- *     
- *     a = [ [ 1, "one"], [2, "two"], [3, "three"], ["ii", "two"] ]
- *     a.rassoc("two")    #=> [2, "two"]
- *     a.rassoc("four")   #=> nil
- */
-
-VALUE
-rb_ary_rassoc(ary, value)
-    VALUE ary, value;
-{
-    long i;
-    VALUE v;
-
-    for (i = 0; i < RARRAY(ary)->len; ++i) {
-	v = RARRAY(ary)->ptr[i];
-	if (TYPE(v) == T_ARRAY &&
-	    RARRAY(v)->len > 1 &&
-	    rb_equal(RARRAY(v)->ptr[1], value))
-	    return v;
-    }
-    return Qnil;
-}
-
-/* 
- *  call-seq:
- *     array == other_array   ->   bool
- *
- *  Equality---Two arrays are equal if they contain the same number
- *  of elements and if each element is equal to (according to
- *  Object.==) the corresponding element in the other array.
- *
- *     [ "a", "c" ]    == [ "a", "c", 7 ]     #=> false
- *     [ "a", "c", 7 ] == [ "a", "c", 7 ]     #=> true
- *     [ "a", "c", 7 ] == [ "a", "d", "f" ]   #=> false
- *
- */
-
-static VALUE
-rb_ary_equal(ary1, ary2)
-    VALUE ary1, ary2;
-{
-    long i;
-
-    if (ary1 == ary2) return Qtrue;
-    if (TYPE(ary2) != T_ARRAY) {
-	if (!rb_respond_to(ary2, rb_intern("to_ary"))) {
-	    return Qfalse;
-	}
-	return rb_equal(ary2, ary1);
-    }
-    if (RARRAY(ary1)->len != RARRAY(ary2)->len) return Qfalse;
-    for (i=0; i<RARRAY(ary1)->len; i++) {
-	if (!rb_equal(rb_ary_elt(ary1, i), rb_ary_elt(ary2, i)))
-	    return Qfalse;
-    }
-    return Qtrue;