summaryrefslogtreecommitdiff
path: root/ice-9
diff options
context:
space:
mode:
Diffstat (limited to 'ice-9')
-rw-r--r--ice-9/ChangeLog-environments37
-rw-r--r--ice-9/arrays.scm106
-rw-r--r--ice-9/check-version.scm22
-rw-r--r--ice-9/config.scm830
-rw-r--r--ice-9/defmacro.scm114
-rw-r--r--ice-9/error.scm37
-rw-r--r--ice-9/files.scm246
-rw-r--r--ice-9/hooks.scm23
-rw-r--r--ice-9/keywords.scm15
-rw-r--r--ice-9/lists.scm23
-rw-r--r--ice-9/macros.scm28
-rw-r--r--ice-9/math.scm102
-rw-r--r--ice-9/misc.scm333
-rw-r--r--ice-9/modules.scm82
-rw-r--r--ice-9/options.scm223
-rw-r--r--ice-9/posix.scm260
-rw-r--r--ice-9/provide.scm13
-rw-r--r--ice-9/repl.scm478
-rw-r--r--ice-9/run-test.scm5
-rw-r--r--ice-9/structs.scm127
-rw-r--r--ice-9/symbols.scm23
21 files changed, 2976 insertions, 151 deletions
diff --git a/ice-9/ChangeLog-environments b/ice-9/ChangeLog-environments
new file mode 100644
index 000000000..963a335f5
--- /dev/null
+++ b/ice-9/ChangeLog-environments
@@ -0,0 +1,37 @@
+1999-08-24 Jost Boekemeier <jostobfe@calvados.zrz.tu-berlin.de>
+
+ * guile.scm (error-catching-loop): Correct non-RnRS usage of internal
+ defines.
+
+1999-08-12 Jost Boekemeier <jostobfe@calvados.zrz.tu-berlin.de>
+
+ * arrays.scm, check-version.scm defmacro.scm, error.scm,
+ files.scm, guile.scm, hooks.scm, keywords.scm lists.scm,
+ macros.scm, math.scm, misc.scm, modules.scm, options.scm
+ posix.scm, provide.scm, run-test.scm, structs.scm, symbols.scm:
+ new file
+ * Makefile.am: added files
+
+ * debug.scm (define-module): the module imports the modules:
+ hooks, options, defmacro
+ (variable-set!): disabled
+
+ * r4rs.scm (defined?): `defined?' is a special form now.
+ (%load-announce): added environment parameter
+ (load): `load' loads and evaluates expressions in
+ `interaction-environment'
+
+ * boot-9.scm: added warning that this module is obsolete
+ (c-module-registry): load all c modules into the root environment
+ (primitive-load-path): load expressions in file "ice-9/r4rs" into
+ interaction-environment
+ (symbol-property): disabled
+ (record-constructor): evaluates expressions in interaction
+ environment
+ (record-accessor): dto.
+ (record-modifier): dto.
+ (modules): disabled
+ (scm-style-repl): evaluates expressions in interaction-environment
+ (environments): disabled
+ (macros): disabled
+ (variables): disabled
diff --git a/ice-9/arrays.scm b/ice-9/arrays.scm
index 51be69210..6e175fde1 100644
--- a/ice-9/arrays.scm
+++ b/ice-9/arrays.scm
@@ -1,83 +1,27 @@
-;;; installed-scm-file
-;;;; Copyright (C) 1999 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
-;;;;
+
+;;; {Arrays}
+;;;
+
+(begin
+ (define uniform-vector? array?)
+ (define make-uniform-vector dimensions->uniform-array)
+ ; (define uniform-vector-ref array-ref)
+ (define (uniform-vector-set! u i o)
+ (uniform-array-set1! u o i))
+ (define uniform-vector-fill! array-fill!)
+ (define uniform-vector-read! uniform-array-read!)
+ (define uniform-vector-write uniform-array-write)
+
+ (define (make-array fill . args)
+ (dimensions->uniform-array args () fill))
+ (define (make-uniform-array prot . args)
+ (dimensions->uniform-array args prot))
+ (define (list->array ndim lst)
+ (list->uniform-array ndim '() lst))
+ (define (list->uniform-vector prot lst)
+ (list->uniform-array 1 prot lst))
+ (define (array-shape a)
+ (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+ (array-dimensions a))))
-(define uniform-vector? array?)
-(define make-uniform-vector dimensions->uniform-array)
-
-;; (define uniform-vector-ref array-ref)
-
-(define (uniform-vector-set! u i o)
- (uniform-array-set1! u o i))
-(define uniform-vector-fill! array-fill!)
-(define uniform-vector-read! uniform-array-read!)
-(define uniform-vector-write uniform-array-write)
-
-(define (make-array fill . args)
- (dimensions->uniform-array args () fill))
-(define (make-uniform-array prot . args)
- (dimensions->uniform-array args prot))
-(define (list->array ndim lst)
- (list->uniform-array ndim '() lst))
-(define (list->uniform-vector prot lst)
- (list->uniform-array 1 prot lst))
-(define (array-shape a)
- (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
- (array-dimensions a)))
-
-(let ((make-array-proc (lambda (template)
- (lambda (c port)
- (read:uniform-vector template port)))))
- (for-each (lambda (char template)
- (read-hash-extend char
- (make-array-proc template)))
- '(#\b #\a #\u #\e #\s #\i #\c #\y #\h #\l)
- '(#t #\a 1 -1 1.0 1/3 0+i #\nul s l)))
-
-(let ((array-proc (lambda (c port)
- (read:array c port))))
- (for-each (lambda (char) (read-hash-extend char array-proc))
- '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))
-
-(define (read:array digit port)
- (define chr0 (char->integer #\0))
- (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
- (if (char-numeric? (peek-char port))
- (readnum (+ (* 10 val)
- (- (char->integer (read-char port)) chr0)))
- val)))
- (prot (if (eq? #\( (peek-char port))
- '()
- (let ((c (read-char port)))
- (case c ((#\b) #t)
- ((#\a) #\a)
- ((#\u) 1)
- ((#\e) -1)
- ((#\s) 1.0)
- ((#\i) 1/3)
- ((#\c) 0+i)
- (else (error "read:array unknown option " c)))))))
- (if (eq? (peek-char port) #\()
- (list->uniform-array rank prot (read port))
- (error "read:array list not found"))))
-
-(define (read:uniform-vector proto port)
- (if (eq? #\( (peek-char port))
- (list->uniform-array 1 proto (read port))
- (error "read:uniform-vector list not found")))
diff --git a/ice-9/check-version.scm b/ice-9/check-version.scm
new file mode 100644
index 000000000..fd3c9e8e6
--- /dev/null
+++ b/ice-9/check-version.scm
@@ -0,0 +1,22 @@
+
+;;; {Check that the interpreter and scheme code match up.}
+
+(let ((show-line
+ (lambda args
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (display (car (command-line)))
+ (display ": ")
+ (for-each (lambda (string) (display string))
+ args)
+ (newline))))))
+
+ (load-from-path "ice-9/version.scm")
+
+ (if (not (string=?
+ (libguile-config-stamp) ; from the interprpreter
+ (ice-9-config-stamp))) ; from the Scheme code
+ (begin
+ (show-line "warning: different versions of libguile and ice-9:")
+ (show-line "libguile: configured on " (libguile-config-stamp))
+ (show-line "ice-9: configured on " (ice-9-config-stamp)))))
diff --git a/ice-9/config.scm b/ice-9/config.scm
new file mode 100644
index 000000000..f31bddd4d
--- /dev/null
+++ b/ice-9/config.scm
@@ -0,0 +1,830 @@
+;;;; This is the (ice-9 config) module. It exports the module
+;;;; configuration language and creates the (user guile) module.
+
+;; from r4rs
+(define (call-with-current-continuation proc)
+ (@call-with-current-continuation proc))
+
+
+;; the export list
+(define the-module-exports
+ '(the-module
+ module
+ module-go
+ go
+ module-ref
+ module-open
+ module-protect
+ module-export
+ module-export
+ module-access
+ module-close
+ module-create
+ module-use
+ (module-use (alias use-modules))
+ (module-export (alias export))
+ (module-export (alias export-syntax))
+ define-module
+ define-public
+ module-config-export
+ module-config-protect
+ module-config-open
+ (define-public (alias define*))
+ (define (alias define-private))
+ symbol-property
+ set-symbol-property!
+ remove-symbol-property!
+ (remove-symbol-property! (alias symbol-property-remove!))
+ ))
+
+(define the-module-protects
+ '(module-eval-environment
+ module-interface-environment
+ module-package-name
+ module-name))
+
+
+
+
+;;; Symbol properties
+(define symbol-property
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,environment-symbol-property (the-environment) ,(cadr x) ,(caddr x) ))))
+
+(define set-symbol-property!
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,environment-set-symbol-property! (the-environment) ,(cadr x) ,(caddr x) ,(cadddr x) ))))
+
+(define remove-symbol-property!
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,environment-remove-symbol-property! (the-environment) ,(cadr x) ,(caddr x) ))))
+
+
+;;; {Error Handling}
+;;;
+
+;; from ice-9 error
+(define (error . args)
+ (if (null? args)
+ (scm-error 'misc-error #f "?" #f #f)
+ (let loop ((msg "%s")
+ (rest (cdr args)))
+ (if (not (null? rest))
+ (loop (string-append msg " %S")
+ (cdr rest))
+ (scm-error 'misc-error #f msg args #f)))))
+
+
+
+;;; {Low Level Modules}
+
+
+;; the module-signature (also called `module') maps modules to:
+;; (vector eval-env export-env protect-env package-sym module-sym)
+(define (module-eval-environment module) (vector-ref module 0))
+
+
+;;; the accessor procedures
+
+;; export environment
+(define (module-export-environment module)
+ (vector-ref module 1))
+
+;;; protect environment
+(define (module-protect-environment module)
+ (vector-ref module 2))
+
+;;; package and module name
+(define (module-package-name module) (vector-ref module 3))
+(define (module-name module) (vector-ref module 4))
+(define (make-module eval export protect package name) (vector eval export protect package name (list )))
+
+;; Return the interface environment for module. The interface is
+;; either the protect environment if the module is accessed from
+;; another package or the module's export environment
+(define module-interface-environment
+ (lambda (current-module module)
+ (if (eq? (module-package-name current-module)
+ (module-package-name module))
+ (module-protect-environment module)
+ (module-export-environment module))))
+
+;; export-list used by define-public
+(define (module-export-list module) (vector-ref module 5))
+(define (module-set-export-list! module val) (vector-set! module 5 val))
+
+;; return the current module-signature
+(define the-module
+ (procedure->syntax
+ (lambda (x env)
+ (let ((m (hashq-ref (environment-module-hash) (car (reverse env)))))
+ (if (not m)
+ (error "PANIC: Could not find module for " (car (reverse env)))
+ m)))))
+
+
+;;; Convert a list of symbols into a package/module name
+
+;; (ice-9 my boot) -> (ice-9/my/ . boot)
+;; (boot) -> (user/ . boot)
+(define symlist->package+module
+ (lambda (symlist)
+ (if (not (pair? symlist)) (error "not a symbol list:" symlist))
+ (let ((symlist (if (null? (cdr symlist)) (cons 'user symlist) symlist)))
+ (let loop ((dirs "")
+ (syms symlist))
+ (let ((sym (car syms)))
+ (if (not (symbol? sym)) (error "not a valid symbol:" sym))
+ (if (null? (cdr syms))
+ (cons (string->symbol dirs) sym)
+ (loop (string-append dirs sym "/") (cdr syms))))))))
+
+;; (ice-9/my/ . boot) -> ice-9/my/boot
+(define package+module->module-sym
+ (lambda (name-pair)
+ (string->symbol
+ (string-append (symbol->string (car name-pair))
+ (symbol->string (cdr name-pair))))))
+
+;; (ice-9/my/ . boot) -> ice-9/my/
+(define package+module->package-sym
+ (lambda (name-pair)
+ (car name-pair)))
+
+;; (ice-9 my boot) -> ice-9/my/boot
+(define symlist->module-sym
+ (lambda (mod)
+ (package+module->module-sym (symlist->package+module mod))))
+
+
+;;; The implementation (low level proc. interface)
+
+;; load and evaluate package-sym module-sym in its own environment
+(define module-load-internal
+ (lambda (package-sym module-sym)
+ (let* (
+ (skel (make-module-skeleton package-sym module-sym))
+ (skel-env (module-eval-environment skel))
+ (c_name (string-append (symbol->string module-sym) ".scm"))
+ (full_name (%search-load-path c_name)))
+
+ (if (not full_name)
+ ;; try to invoke c-function directly
+ (let (
+ (c_module_init (and
+ (environment-bound? (c-module-registry) module-sym)
+ (environment-ref (c-module-registry) module-sym))))
+ (if (not c_module_init)
+ (begin
+ ;; remove all references to the created module
+ (environment-undefine (module-registry) module-sym)
+ #f)
+ (begin
+ (c_module_init skel-env)
+
+ ;; now modify the export and protect environment so
+ ;; that all cells are visible
+ (let ((export (module-export-environment skel)))
+ (interface-environment-set-interface!
+ export
+ (list (cons skel-env (environment-fold skel-env (lambda (sym val last) (cons sym last)) (list )))))
+ (interface-environment-set-interface! (module-protect-environment skel) (list (cons export #f))))
+
+ skel)))
+
+ (begin
+ (primitive-load full_name skel-env)
+ skel)))))
+
+;; load `(package module)'
+(define module-load-proc
+ (lambda (mod)
+ (let* (
+ (name-pair (symlist->package+module mod))
+ (package-sym (package+module->package-sym name-pair))
+ (module-sym (package+module->module-sym name-pair)))
+ (module-load-internal package-sym module-sym))))
+
+(define last-indent 0)
+
+;; load package-sym/module-sym only if module has not been loaded
+(define module-auto-load
+ (lambda (package-sym module-sym)
+ (let (
+ (module (and
+ (environment-bound? (module-registry) module-sym)
+ (environment-ref (module-registry) module-sym)))
+ (indent (lambda (count)
+ (do ((i 0 (+ i 1))) ((= i count)) (display " ")))))
+
+ (if (not module)
+
+ (begin
+ (display "loading ")
+ (indent last-indent)
+ (display module-sym) (force-output)
+ (newline)
+
+ (set! last-indent (+ last-indent 2))
+ (let ((module (module-load-internal package-sym module-sym)))
+
+ (set! last-indent (- last-indent 2))
+ module))
+
+ module))))
+
+;; Create a continuation to start a new repl in module.
+;; #f means: start a repl in (user config)
+(define module-go
+ (lambda (module)
+
+ (define (y-or-n? question eof-value count)
+ (let ((i-port (current-input-port))
+ (o-port (current-output-port)))
+ (let loop ((count count))
+ (display question o-port)
+ (display " (y/n)? " o-port)
+ (force-output)
+ (let ((line (read i-port)))
+ (cond ((eof-object? line)
+ (newline o-port)
+ (if (= count 0)
+ eof-value
+ (begin (display "I'll only ask another " o-port)
+ (write count o-port)
+ (display " times." o-port)
+ (newline o-port)
+ (loop (- count 1)))))
+ ((< (string-length line) 1) (loop count))
+ ((char=? (string-ref line 0) #\y) #t)
+ ((char=? (string-ref line 0) #\n) #f)
+ (else (loop count)))))))
+
+ (let ((guile (module-access-proc '(ice-9 repl)))
+ (user/config (module-create (user config)))
+ (quit (lambda args
+ (apply throw 'quit args))))
+
+ ;; (user config) opens the current module (ice-9 config) and
+ ;; imports some symbols
+ (let ((interface (eval-environment-imported (module-eval-environment user/config)))
+ (export (module-export-environment (the-module)))
+ (import-list '(module-ref module-access module-close module-create the-module
+ module-use define-module module module-go go
+ (module-config-export (alias config-export))
+ (module-config-protect (alias config-protect))
+ (module-config-open (alias config-open)))))
+
+ (interface-environment-set-interface! interface (list (cons export import-list))))
+
+
+ (let (
+ (top-repl (module-ref-proc (the-module) guile 'top-repl)))
+
+ (let (
+ (in-module (call-with-current-continuation (lambda (k) (set! module-go k) module))))
+
+ (letrec (
+ (confirm
+ (lambda ()
+ (newline)
+ (y-or-n? "Do you really want to quit guile" #t 1)))
+
+ (user-repl
+ (lambda ()
+ (set-interaction-environment! (module-eval-environment in-module))
+ (let ((ret-val (top-repl in-module)))
+ (newline)
+ ret-val)))
+
+ (config-repl
+ (lambda ()
+ (set-interaction-environment! (module-eval-environment user/config))
+ (top-repl user/config))))
+
+ (let (
+ (ret-val
+ (or (and in-module (user-repl)) (config-repl))))
+
+ (if (not (confirm)) (module-go #f))
+
+ ret-val)))))))
+
+;; fix the interface of the guile module.
+(let* (
+ (guile-module (environment-ref (module-registry) 'ice-9/guile))
+ (guile-eval-env (module-eval-environment guile-module))
+ (guile-export-list (environment-fold guile-eval-env (lambda (sym val rest) (cons sym rest)) '()))
+ (guile-interface (list (cons guile-eval-env guile-export-list)))
+ (export (module-export-environment guile-module))
+ (protect (module-protect-environment guile-module)))
+
+ ;; get out your barf bag ... It is probably better to export
+ ;; %load-path from (ice-9 config) and *features* from whereever but
+ ;; not from the guile module
+ ;;
+ ; export mutable
+ (for-each (lambda (s)
+ (set-car! (memq s guile-export-list) (list s 'mutable-location)))
+ (list
+ '%load-path
+ '*features*
+ ; complete weired ... (from r4rs.scm)
+ '%load-hook
+ 'apply
+ ; argh... (popen.scm)
+ 'gc-thunk
+ ))
+
+
+
+ ; now set the interface
+ (interface-environment-set-interface! export guile-interface)
+ (interface-environment-set-interface! protect guile-interface))
+
+;; update the config module `(ice-9 config)'
+(let* (
+ (config-module (environment-ref (module-registry) 'ice-9/config))
+ (eval (module-eval-environment config-module))
+ (export (module-export-environment config-module))
+ (protect (module-protect-environment config-module)))
+
+ (interface-environment-set-interface! export (list (cons eval the-module-exports)))
+ (interface-environment-set-interface! protect (list (cons eval the-module-protects) (cons export #f))))
+
+;; create a simple but full-featured module.
+(define make-module-skeleton
+ (lambda (package-sym module-sym)
+ (let* (
+ (config-export-env (module-export-environment
+ (environment-ref (module-registry) 'ice-9/config)))
+ (local (make-leaf-environment))
+ (import (make-interface-environment (list (cons config-export-env #f))))
+ (eval (make-eval-environment local import))
+ (export (make-interface-environment (list (list eval)))) ;; export nothing
+ (protect (make-interface-environment (list (cons export #f) (list eval))))
+ (module (make-module eval export protect package-sym module-sym)))
+
+ (hashq-set! (environment-module-hash) eval module)
+ (environment-define (module-registry) module-sym module)
+
+ module)))
+
+(define module-create-proc
+ (lambda (mod)
+ (let* (
+ (name-pair (symlist->package+module mod))
+ (package-sym (package+module->package-sym name-pair))
+ (module-sym (package+module->module-sym name-pair))
+ (module (and
+ (environment-bound? (module-registry) module-sym)
+ (environment-ref (module-registry) module-sym))))
+
+ (if (not module)
+ (let* (
+ (c_name (string-append (symbol->string module-sym) ".scm"))
+ (full_name (%search-load-path c_name)))
+ (if (not full_name)
+ (let* (
+ (skel (make-module-skeleton package-sym module-sym))
+ (eval-env (module-eval-environment skel)))
+ skel)
+
+ (error "module exists but has not been loaded" module-sym)))
+ (error "module exists and has been loaded" module-sym)))))
+
+
+(define module-load-error
+ (lambda (module-sym)
+ (error "module could not be loaded" module-sym)))
+
+;; add an export environment to our module skeleton or set a new
+(define (module-export-proc module export-list)
+ (let (
+ (export (module-export-environment module))
+ (eval (module-eval-environment module)))
+
+ (if (pair? (module-export-list module))
+ (error "You can either use `define-public' or `export', but not both."))
+
+ (module-set-export-list! module #f) ;; can't use `define-public' anymore
+
+ (interface-environment-set-interface! export (list (cons eval export-list)))
+ (if #f #f)))
+
+;; package boundary
+(define (module-protect-proc module protect-list)
+ (let ((protect (module-protect-environment module))
+ (export (module-export-environment module))
+ (eval (module-eval-environment module)))
+
+ (interface-environment-set-interface! protect (list (cons eval protect-list) (cons export #f)))
+ (if #f #f)))
+
+
+;; check for circular references
+;; every interface-environment has a list of environment specs
+;; an environment spec is a list of the environment and its exported symbols
+;; every eval-environment has an interface-environment
+(define referenced
+ (lambda (environment l)
+ (letrec (
+ (search
+ (lambda (l)
+ (cond ((null? l) #f)
+ ((eq? (caar l) environment) #t)
+ (else
+ (or (search (get-list-from-env (caar l)))
+ (search (cdr l)))))))
+
+ (get-list-from-env
+ (lambda (env)
+ (cond ((interface-environment? env)
+ (interface-environment-interface env))
+
+ ((eval-environment? env)
+ (get-list-from-env (eval-environment-imported env)))
+
+ (else (error "FIXME: unsupported environment" env))))))
+
+ (search l))))
+
+
+(define module-access-proc
+ (lambda (mod)
+ (let* (
+ (name-pair (symlist->package+module mod))
+ (package-sym (package+module->package-sym name-pair))
+ (module-sym (package+module->module-sym name-pair)))
+
+ (or (module-auto-load package-sym module-sym)
+ (module-load-error module-sym)))))
+
+
+;; remove module from module-registry
+(define module-close-proc
+ (lambda (mod)
+ (let* (
+ (name-pair (symlist->package+module mod))
+ (package-sym (package+module->package-sym name-pair))
+ (module-sym (package+module->module-sym name-pair)))
+
+ (environment-undefine (module-registry) module-sym))))
+
+
+(define module-open-internal
+ (lambda (skel imports)
+
+ (let* (
+ (eval (module-eval-environment skel))
+ (import (eval-environment-imported eval)))
+
+ (if (referenced eval imports)
+ (error "Can't open modules: circular dependency for " eval))
+
+ (interface-environment-set-interface! import imports))))
+
+(define import-symlist->import-list
+ (lambda (skel import-symlist)
+ (letrec
+ ((fix-imports
+ (lambda (l)
+ (cond
+ ((null? l) '())
+ ((not (list? (caar l))) (cons (cons (car l) #f) (fix-imports (cdr l))))
+ (else (cons (car l) (fix-imports (cdr l))))))))
+
+ (let* (
+ (import-symlist (fix-imports import-symlist))
+ (import-modlist (map (lambda (x) (cons (module-access-proc (car x)) (cdr x))) import-symlist))
+ (import-list (map (lambda (x) (cons (module-interface-environment skel (car x)) (cdr x))) import-modlist)))
+
+ import-list))))
+
+(define module-open-proc
+ (lambda (skel import-symlist)
+ (module-open-internal skel (import-symlist->import-list skel import-symlist))))
+
+(define module-use-proc
+ (lambda (skel import-symlist)
+ (let* (
+ (eval (module-eval-environment skel))
+ (interface-env (eval-environment-imported eval))
+ (interface (interface-environment-interface interface-env))
+ (import-list (import-symlist->import-list skel import-symlist)))
+
+ (module-open-internal skel (append import-list interface))
+ (if #f #f)
+ )))
+
+
+(define module-ref-proc
+ (lambda (curr module sym)
+ (let (
+ (name (module-name module))
+ (interface-env (module-interface-environment curr module))
+ )
+
+ (cond
+ ((environment-bound? interface-env sym)
+ (environment-ref interface-env sym))
+
+ (else (scm-error 'misc-error #f "Symbol `%s' is not exported from `%s'." (list sym name) #f))))))
+
+
+(define (module-proc current-module args)
+ (let* (
+ (mod (car args))
+ (arglist (cdr args))
+ (current-module-sym (module-name current-module))
+ (sym (symlist->module-sym mod))
+ (same-module (eq? current-module-sym sym))
+ (has-exports (assq 'export arglist))
+ (skel (if same-module current-module (module-create-proc mod))))
+
+ (let loop ((arglist arglist)
+ (modules '())
+ (exports '())
+ (protects '()))
+
+ (if (null? arglist)
+ (begin
+
+ (if (not same-module)
+ (error "Can't manipulate a foreign module's interface."))
+
+ (module-open-proc skel modules)
+
+ (if has-exports (module-export-proc skel exports))
+
+ (module-protect-proc skel protects)
+ )
+
+
+ (begin
+ (if (not (pair? (car arglist)))
+ (error "unrecognized module argument in" current-module-sym))
+
+ (let ((fkt (caar arglist)))
+ (case fkt
+ ((open)
+ (loop (cdr arglist)
+ (append modules (cdar arglist))
+ exports
+ protects))
+
+ ((export)
+ (loop (cdr arglist)
+ modules
+ (append exports (cdar arglist))
+ protects))
+
+ ((protect)
+ (loop (cdr arglist)
+ modules
+ exports
+ (append protects (cdar arglist))))
+ (else
+ (error "unrecognized module argument in" current-module-sym)))))))))
+
+(define (go-proc module)
+ (module-go (module-access-proc module)))
+
+
+;;; High level interface
+
+;; declare a module
+(define module
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-proc (,the-module) (,quote ,(cdr x) )))))
+
+;; open module and start a repl in it
+(define go
+ (procedure->memoizing-macro
+ (lambda (x env)
+ (if (not (list? (cadr x))) (error "not a list:" (cadr x)))
+ `(,go-proc (,quote ,(cadr x))))))
+
+
+;;; low level interface
+
+;; access symbol exported from module
+(define module-ref
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-ref-proc (,the-module) ,(cadr x) ,(caddr x)))))
+
+;; add module to import-list
+(define module-use
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-use-proc (,the-module) (,quote ,(cdr x))))))
+
+;; start a new import-list
+(define module-open
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-open-proc (,the-module) (,quote ,(cdr x))))))
+
+;; load a module
+(define module-load
+ (procedure->memoizing-macro
+ (lambda (x env)
+ (if (not (
+ list? (cadr x))) (error "not a list:" (cadr x)))
+ `(,module-load-proc (,quote ,(cadr x))))))
+
+;; publish symbols (visible to all other modules)
+(define module-protect
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-protect-proc (,the-module) (,quote ,(cdr x) )))))
+
+;; make symbols visible to modules that belong the current package
+(define module-export
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-export-proc (,the-module) (,quote ,(cdr x))))))
+
+;; open a module and return a handle
+(define module-access
+ (procedure->memoizing-macro
+ (lambda (x env)
+ (if (not (list? (cadr x))) (error "not a list:" (cadr x)))
+ `(,module-access-proc (,quote ,(cadr x))))))
+
+;; close a module (remove it from the module-registry)
+(define module-close
+ (procedure->memoizing-macro
+ (lambda (x env)
+ (if (not (list? (cadr x))) (error "not a list:" (cadr x)))
+ `(,module-close-proc (,quote ,(cadr x))))))
+
+;; create a in-memory module and return a handle
+(define module-create
+ (procedure->memoizing-macro
+ (lambda (x env)
+ (if (not (list? (cadr x))) (error "not a list:" (cadr x)))
+ `(,module-create-proc (,quote ,(cadr x) )))))
+
+;; import symbols from other modules
+(define module-config-open
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-open-proc (,module-access-proc (,quote ,(cadr x))) (,quote ,(cddr x))))))
+
+;; make symbols visible within the current package
+(define module-config-protect
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-protect-proc (,module-access-proc (,quote ,(cadr x))) (,quote ,(cddr x))))))
+
+;; make symbols visible to the world
+(define module-config-export
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,module-export-proc (,module-access-proc (,quote ,(cadr x))) (,quote ,(cddr x))))))
+
+
+;;; For backward compatibility
+;;;
+
+(define (define-module-proc current-module args)
+ (let* (
+ (kws (cdr args))
+ (current-module-sym (module-name current-module))
+ (mod (car args))
+ (sym (symlist->module-sym mod))
+
+ ;; do not create a new module if the module names are the
+ ;; same and the current module has not been closed
+ (same-module (and (eq? current-module-sym sym)
+ (environment-bound? (module-registry) current-module-sym)))
+
+ (skel (if same-module
+ current-module
+ (module-create-proc mod))))
+
+
+ (let loop ((kws kws)
+ (modules '()))
+ (if (null? kws)
+ (begin
+ ;; append (ice-9 guile) and (ice-9 config) for convenience
+ (module-open-proc skel (cons '(ice-9 config) (cons '(ice-9 guile) modules)))
+ (if (not same-module) (module-go (module-access-proc mod)))
+ )
+
+ (let ((keyword (car kws)))
+ (let ((keyword (if (keyword? keyword) (keyword->symbol keyword) keyword)))
+ (case keyword
+ ((use-module use-syntax autoload :use-module :use-syntax :autoload)
+ (let (
+ (mod (cadr kws)))
+
+ (if (not (pair? mod))
+ (error "unrecognized defmodule argument" kws))
+
+ (loop (cddr kws)
+ (cons mod modules))))
+ ((no-backtrace :no-backtrace)
+ (loop (cdr kws) modules))
+ (else
+ (error "unrecognized defmodule argument" kws)))))))))
+
+(define define-module
+ (procedure->memoizing-macro
+ (lambda (x env)
+ `(,define-module-proc (,the-module) (,quote ,(cdr x) )))))
+
+;; rewrite me
+(define define-public
+ (procedure->memoizing-macro
+ (lambda (x env)
+ (let ((args (cdr x)))
+ (letrec (
+ (syntax (lambda ()
+ (error "bad syntax" (list 'define-public args))))
+ (defined-name
+ (lambda (n)
+ (cond
+ ((symbol? n) n)
+ ((pair? n) (defined-name (car n)))
+ (else (syntax)))))
+ )
+
+ (if (null? args) (syntax))
+
+ (let (
+ (name (defined-name (car args))))
+
+ `(begin
+ (letrec (
+ ;; according to environment proposal either
+ ;; symbol or (sym tags)
+ (get-symbol
+ (lambda (s)
+ (cond
+ ((pair? s) (car s))
+ (else s))))
+
+ ;; test if symbol is already exported
+ (exported?
+ (lambda (sym l)
+ (cond
+ ((null? l) #f)
+ ((eq? (get-symbol (car l)) sym) #t)
+ (else (exported? sym (cdr l)))))))
+
+ (let* (
+ (module-eval-environment ,module-eval-environment)
+ (module-export-environment ,module-export-environment)
+ (interface-environment-interface ,interface-environment-interface)
+ (environment-bound? ,environment-bound?)
+ (environment-ref ,environment-ref)
+ (environment-define ,environment-define)
+ (the-module ,the-module)
+ (the-environment ,the-environment)
+ (interface-environment-set-interface! ,interface-environment-set-interface!)
+ (module-export-list ,module-export-list)
+
+ (module (the-module))
+ (eval-env (module-eval-environment module))
+ (export (module-export-environment module))
+ (export-list (module-export-list module))
+
+ (val (,and (,environment-bound? eval-env ',name)
+ (,environment-ref eval-env ',name))))
+
+ (if (not (list? export-list))
+ (,error "You can either use `define-public' or `export', but not both"))
+
+ (if (not (memq ',name export-list))
+ (begin
+ (environment-define eval-env ',name val)
+ (set! export-list (cons ',name export-list))
+ (,module-set-export-list! module export-list)
+ (interface-environment-set-interface!
+ export
+ (list (cons eval-env export-list)))))
+
+
+
+ ;; Now (re)define the var normally. Bernard URBAN
+ ;; suggests we use eval here to accomodate Hobbit; it lets
+ ;; the interpreter handle the define-private form, which
+ ;; Hobbit can't digest.
+ (eval '(define ,@ args) (the-environment))
+
+ )))))))))
+
+
+;; the entry point (called by (ice-9 repl))
+(define start
+ (lambda ()
+ (module-go #f)))
+
diff --git a/ice-9/defmacro.scm b/ice-9/defmacro.scm
new file mode 100644
index 000000000..c0c96a526
--- /dev/null
+++ b/ice-9/defmacro.scm
@@ -0,0 +1,114 @@
+(module (ice-9 defmacro)
+ (open (ice-9 error)
+ (ice-9 provide)
+ (ice-9 guile))
+ (export defmacro gentemp defmacro:transformer defmacro:syntax-transformer))
+
+
+;;; {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)))
+ `(define ,name
+ (,(lambda (transformer)
+ (defmacro:transformer transformer))
+ ,transformer))))))
+ (defmacro:transformer defmacro-transformer)))
+
+
+; (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
+; (let* (
+; (module (the-module))
+; (eval (module-eval-environment module))
+
+; ;; look up the old value first
+; (val (if (environment-bound? eval ',name)
+; (environment-ref eval ',name)
+; (begin
+; (environment-define eval ',name #f)
+; #f)))
+
+; (export (module-export-environment module)))
+; (if (not (environment? export))
+; (let ( ;; create export environment
+; (export (make-export-environment eval (list ',name))))
+; (module-export-environment-set! module export)
+; )
+; (environment-define export ',name val)))
+
+; ;; Now (re)define the var normally.
+; ;;
+; (defmacro ,@ args))))))
+
+(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)))
+
+(define (gentemp)
+ (gensym "scm:G"))
+
+(provide 'defmacro)
+
diff --git a/ice-9/error.scm b/ice-9/error.scm
new file mode 100644
index 000000000..8da006d4f
--- /dev/null
+++ b/ice-9/error.scm
@@ -0,0 +1,37 @@
+;;; {Error Handling}
+;;;
+
+(module (ice-9 error)
+ (open (ice-9 guile)
+ ((ice-9 repl) save-stack))
+ (export error warn))
+
+(define (error . args)
+ (save-stack)
+ (if (null? args)
+ (scm-error 'misc-error #f "?" #f #f)
+ (let loop ((msg "%s")
+ (rest (cdr args)))
+ (if (not (null? rest))
+ (loop (string-append msg " %S")
+ (cdr rest))
+ (scm-error 'misc-error #f msg args #f)))))
+
+;; bad-throw is the hook that is called upon a throw to a an unhandled
+;; key (unless the throw has four arguments, in which case
+;; it's usually interpreted as an error throw.)
+;; If the key has a default handler (a throw-handler-default property),
+;; it is applied to the throw.
+;;
+(define (bad-throw key . args)
+ (apply error "unhandled-exception:" key args))
+
+
+(define (warn . stuff)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (newline)
+ (display ";;; WARNING ")
+ (display stuff)
+ (newline)
+ (car (last-pair stuff))))) \ No newline at end of file
diff --git a/ice-9/files.scm b/ice-9/files.scm
new file mode 100644
index 000000000..7c150530c
--- /dev/null
+++ b/ice-9/files.scm
@@ -0,0 +1,246 @@
+(module (ice-9 files)
+
+ (open (ice-9 posix)
+ (ice-9 guile)
+ (ice-9 provide)
+ ((ice-9 strorder) string=?))
+
+ (export scm-line-incrementors
+ read-line
+ file-exists?
+ file-is-directory?
+ has-suffix?
+ load-from-path
+ (dev (alias stat:dev))
+ (ino (alias stat:ino))
+ (mode (alias stat:mode))
+ (nlink (alias stat:nlink))
+ (uid (alias stat:uid))
+ (gid (alias stat:gid))
+ (rdev (alias stat:rdev))
+ (size (alias stat:size))
+ (atime (alias stat:atime))
+ (mtime (alias stat:mtime))
+ (ctime (alias stat:ctime))
+ (blksize (alias stat:blksize))
+ (blocks (alias stat:blocks))
+ (type (alias stat:type))
+ (perms (alias stat:perms))
+ read-delimited
+ read-delimited!
+ ))
+
+
+;;; {Line and Delimited I/O}
+
+;;; corresponds to SCM_LINE_INCREMENTORS in libguile.
+(define scm-line-incrementors "\n")
+
+(define (read-line! string . maybe-port)
+ (let* ((port (if (pair? maybe-port)
+ (car maybe-port)
+ (current-input-port))))
+ (let* ((rv (%read-delimited! scm-line-incrementors
+ string
+ #t
+ port))
+ (terminator (car rv))
+ (nchars (cdr rv)))
+ (cond ((and (= nchars 0)
+ (eof-object? terminator))
+ terminator)
+ ((not terminator) #f)
+ (else nchars)))))
+
+(define (read-delimited! delims buf . args)
+ (let* ((num-args (length args))
+ (port (if (> num-args 0)
+ (car args)
+ (current-input-port)))
+ (handle-delim (if (> num-args 1)
+ (cadr args)
+ 'trim))
+ (start (if (> num-args 2)
+ (caddr args)
+ 0))
+ (end (if (> num-args 3)
+ (cadddr args)
+ (string-length buf))))
+ (let* ((rv (%read-delimited! delims
+ buf
+ (not (eq? handle-delim 'peek))
+ port
+ start
+ end))
+ (terminator (car rv))
+ (nchars (cdr rv)))
+ (cond ((or (not terminator) ; buffer filled
+ (eof-object? terminator))
+ (if (zero? nchars)
+ (if (eq? handle-delim 'split)
+ (cons terminator terminator)
+ terminator)
+ (if (eq? handle-delim 'split)
+ (cons nchars terminator)
+ nchars)))
+ (else
+ (case handle-delim
+ ((trim peek) nchars)
+ ((concat) (string-set! buf nchars terminator)
+ (+ nchars 1))
+ ((split) (cons nchars terminator))
+ (else (error "unexpected handle-delim value: "
+ handle-delim))))))))
+
+(define (read-delimited delims . args)
+ (let* ((port (if (pair? args)
+ (let ((pt (car args)))
+ (set! args (cdr args))
+ pt)
+ (current-input-port)))
+ (handle-delim (if (pair? args)
+ (car args)
+ 'trim)))
+ (let loop ((substrings ())
+ (total-chars 0)
+ (buf-size 100)) ; doubled each time through.
+ (let* ((buf (make-string buf-size))
+ (rv (%read-delimited! delims
+ buf
+ (not (eq? handle-delim 'peek))
+ port))
+ (terminator (car rv))
+ (nchars (cdr rv))
+ (join-substrings
+ (lambda ()
+ (apply string-append
+ (reverse
+ (cons (if (and (eq? handle-delim 'concat)
+ (not (eof-object? terminator)))
+ (string terminator)
+ "")
+ (cons (make-shared-substring buf 0 nchars)
+ substrings))))))
+ (new-total (+ total-chars nchars)))
+ (cond ((not terminator)
+ ;; buffer filled.
+ (loop (cons (substring buf 0 nchars) substrings)
+ new-total
+ (* buf-size 2)))
+ ((eof-object? terminator)
+ (if (zero? new-total)
+ (if (eq? handle-delim 'split)
+ (cons terminator terminator)
+ terminator)
+ (if (eq? handle-delim 'split)
+ (cons (join-substrings) terminator)
+ (join-substrings))))
+ (else
+ (case handle-delim
+ ((trim peek concat) (join-substrings))
+ ((split) (cons (join-substrings) terminator))
+
+
+ (else (error "unexpected handle-delim value: "
+ handle-delim)))))))))
+
+;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
+;;; from PORT. The return value depends on the value of HANDLE-DELIM,
+;;; which may be one of the symbols `trim', `concat', `peek' and
+;;; `split'. If it is `trim' (the default), the trailing newline is
+;;; removed and the string is returned. If `concat', the string is
+;;; returned with the trailing newline intact. If `peek', the newline
+;;; is left in the input port buffer and the string is returned. If
+;;; `split', the newline is split from the string and read-line
+;;; returns a pair consisting of the truncated string and the newline.
+
+(define (read-line . args)
+ (let* ((port (if (null? args)
+ (current-input-port)
+ (car args)))
+ (handle-delim (if (> (length args) 1)
+ (cadr args)
+ 'trim))
+ (line/delim (%read-line port))
+ (line (car line/delim))
+ (delim (cdr line/delim)))
+ (case handle-delim
+ ((trim) line)
+ ((split) line/delim)
+ ((concat) (if (and (string? line) (char? delim))
+ (string-append line (string delim))
+ line))
+ ((peek) (if (char? delim)
+ (unread-char delim port))
+ line)
+ (else
+ (error "unexpected handle-delim value: " handle-delim)))))
+
+
+
+;;; {Files}
+;;;
+;;; If no one can explain this comment to me by 31 Jan 1998, I will
+;;; assume it is meaningless and remove it. -twp
+;;; !!!! these should be implemented using Tcl commands, not fports.
+
+;; Using the vector returned by stat directly is probably not a good
+;; idea (it could just as well be a record). Hence some accessors.
+(define (dev f) (vector-ref f 0))
+(define (ino f) (vector-ref f 1))
+(define (mode f) (vector-ref f 2))
+(define (nlink f) (vector-ref f 3))
+(define (uid f) (vector-ref f 4))
+(define (gid f) (vector-ref f 5))
+(define (rdev f) (vector-ref f 6))
+(define (size f) (vector-ref f 7))
+(define (atime f) (vector-ref f 8))
+(define (mtime f) (vector-ref f 9))
+(define (ctime f) (vector-ref f 10))
+(define (blksize f) (vector-ref f 11))
+(define (blocks f) (vector-ref f 12))
+
+;; derived from stat mode.
+(define (type f) (vector-ref f 13))
+(define (perms f) (vector-ref f 14))
+
+(define file-exists?
+ (if (feature? 'posix)
+ (lambda (str)
+ (access? str F_OK))
+ (lambda (str)
+ (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
+
+(define file-is-directory?
+ (if (feature? 'i/o-extensions)
+ (lambda (str)
+ (eq? (type (stat str)) 'directory))
+ (lambda (str)
+ (display str)
+ (newline)
+ (let ((port (catch 'system-error
+ (lambda () (open-file (string-append str "/.")
+ OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
+
+(define (has-suffix? str suffix)
+ (let ((sufl (string-length suffix))
+ (sl (string-length str)))
+ (and (> sl sufl)
+ (string=? (substring str (- sl sufl) sl) suffix))))
+
+
+;;; {Loading by paths}
+
+;;; Load a Scheme source file named NAME, searching for it in the
+;;; directories listed in %load-path, and applying each of the file
+;;; name extensions listed in %load-extensions.
+(define (load-from-path name)
+ (start-stack 'load-stack
+ (primitive-load-path name (interaction-environment))))
+
diff --git a/ice-9/hooks.scm b/ice-9/hooks.scm
new file mode 100644
index 000000000..a6e4f6c6b
--- /dev/null
+++ b/ice-9/hooks.scm
@@ -0,0 +1,23 @@
+;;; {Hooks}
+;;;
+;;; Warning: Hooks are now first class objects and add-hook! and remove-hook!
+;;; procedures. This interface is only provided for backward compatibility
+;;; and will be removed.
+;;;
+(module-open (ice-9 guile))
+(if (not (defined? new-add-hook!))
+ (begin
+ (define new-add-hook! add-hook!)
+ (define new-remove-hook! remove-hook!)))
+
+(define (run-hooks hook)
+ (if (and (pair? hook) (eq? (car hook) 'hook))
+ (run-hook hook)
+ (for-each (lambda (thunk) (thunk)) hook)))
+
+(define *suppress-old-style-hook-warning* #f)
+
+(define abort-hook (make-hook))
+
+
+
diff --git a/ice-9/keywords.scm b/ice-9/keywords.scm
new file mode 100644
index 000000000..da45f046a
--- /dev/null
+++ b/ice-9/keywords.scm
@@ -0,0 +1,15 @@
+
+;;; {Keywords}
+;;;
+
+(define (symbol->keyword symbol)
+ (make-keyword-from-dash-symbol (symbol-append '- symbol)))
+
+(define (keyword->symbol kw)
+ (let ((sym (keyword-dash-symbol kw)))
+ (string->symbol (substring sym 1 (string-length sym)))))
+
+(define (kw-arg-ref args kw)
+ (let ((rem (member kw args)))
+ (and rem (pair? (cdr rem)) (cadr rem))))
+
diff --git a/ice-9/lists.scm b/ice-9/lists.scm
new file mode 100644
index 000000000..654bab60e
--- /dev/null
+++ b/ice-9/lists.scm
@@ -0,0 +1,23 @@
+;;; {Lists}
+;;;
+(module (ice-9 lists)
+ (open (ice-9 guile))
+ (export list-index make-list))
+
+(define (list-index l k)
+ (let loop ((n 0)
+ (l l))
+ (and (not (null? l))
+ (if (eq? (car l) k)
+ n
+ (loop (+ n 1) (cdr l))))))
+
+(define (make-list n . init)
+ (if (pair? init) (set! init (car init)))
+ (let loop ((answer '())
+ (n n))
+ (if (<= n 0)
+ answer
+ (loop (cons init answer) (- n 1)))))
+
+
diff --git a/ice-9/macros.scm b/ice-9/macros.scm
new file mode 100644
index 000000000..e697861d1
--- /dev/null
+++ b/ice-9/macros.scm
@@ -0,0 +1,28 @@
+;;; {Macros}
+;;;
+
+;; actually....hobbit might be able to hack these with a little
+;; coaxing
+;;
+(module (ice-9 macros)
+ (export define-macro define-syntax-macro defmacro:transformer defmacro:syntax-transformer)
+ (open (ice-9 guile) (ice-9 defmacro)))
+
+
+(defmacro define-macro (first . rest)
+ (let ((name (if (symbol? first) first (car first)))
+ (transformer
+ (if (symbol? first)
+ (car rest)
+ `(lambda ,(cdr first) ,@rest))))
+ `(define ,name (defmacro:transformer ,transformer))))
+
+
+(defmacro define-syntax-macro (first . rest)
+ (let ((name (if (symbol? first) first (car first)))
+ (transformer
+ (if (symbol? first)
+ (car rest)
+ `(lambda ,(cdr first) ,@rest))))
+ `(define ,name (defmacro:syntax-transformer ,transformer))))
+
diff --git a/ice-9/math.scm b/ice-9/math.scm
new file mode 100644
index 000000000..f60d284e1
--- /dev/null
+++ b/ice-9/math.scm
@@ -0,0 +1,102 @@
+
+;;; {Transcendental Functions}
+;;;
+;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
+;;; Written by Jerry D. Hedden, (C) FSF.
+;;; See the file `COPYING' for terms applying to this program.
+;;;
+
+(define (exp z)
+ (if (real? z) ($exp z)
+ (make-polar ($exp (real-part z)) (imag-part z))))
+
+(define (log z)
+ (if (and (real? z) (>= z 0))
+ ($log z)
+ (make-rectangular ($log (magnitude z)) (angle z))))
+
+(define (sqrt z)
+ (if (real? z)
+ (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
+ ($sqrt z))
+ (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
+
+(define expt
+ (let ((integer-expt integer-expt))
+ (lambda (z1 z2)
+ (cond ((exact? z2)
+ (integer-expt z1 z2))
+ ((and (real? z2) (real? z1) (>= z1 0))
+ ($expt z1 z2))
+ (else
+ (exp (* z2 (log z1))))))))
+
+(define (sinh z)
+ (if (real? z) ($sinh z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($sinh x) ($cos y))
+ (* ($cosh x) ($sin y))))))
+(define (cosh z)
+ (if (real? z) ($cosh z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($cosh x) ($cos y))
+ (* ($sinh x) ($sin y))))))
+(define (tanh z)
+ (if (real? z) ($tanh z)
+ (let* ((x (* 2 (real-part z)))
+ (y (* 2 (imag-part z)))
+ (w (+ ($cosh x) ($cos y))))
+ (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
+
+(define (asinh z)
+ (if (real? z) ($asinh z)
+ (log (+ z (sqrt (+ (* z z) 1))))))
+
+(define (acosh z)
+ (if (and (real? z) (>= z 1))
+ ($acosh z)
+ (log (+ z (sqrt (- (* z z) 1))))))
+
+(define (atanh z)
+ (if (and (real? z) (> z -1) (< z 1))
+ ($atanh z)
+ (/ (log (/ (+ 1 z) (- 1 z))) 2)))
+
+(define (sin z)
+ (if (real? z) ($sin z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($sin x) ($cosh y))
+ (* ($cos x) ($sinh y))))))
+(define (cos z)
+ (if (real? z) ($cos z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($cos x) ($cosh y))
+ (- (* ($sin x) ($sinh y)))))))
+(define (tan z)
+ (if (real? z) ($tan z)
+ (let* ((x (* 2 (real-part z)))
+ (y (* 2 (imag-part z)))
+ (w (+ ($cos x) ($cosh y))))
+ (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
+
+(define (asin z)
+ (if (and (real? z) (>= z -1) (<= z 1))
+ ($asin z)
+ (* -i (asinh (* +i z)))))
+
+(define (acos z)
+ (if (and (real? z) (>= z -1) (<= z 1))
+ ($acos z)
+ (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
+
+(define (atan z . y)
+ (if (null? y)
+ (if (real? z) ($atan z)
+ (/ (log (/ (- +i z) (+ +i z))) +2i))
+ ($atan2 z (car y))))
+
+(set! abs magnitude)
+
+(define (log10 arg)
+ (/ (log arg) (log 10)))
+
diff --git a/ice-9/misc.scm b/ice-9/misc.scm
new file mode 100644
index 000000000..6c892e7d7
--- /dev/null
+++ b/ice-9/misc.scm
@@ -0,0 +1,333 @@
+(module (ice-9 misc)
+ (export in-vicinity with-fluids)
+ (open (ice-9 structs) (ice-9 files) (ice-9 defmacro) (ice-9 provide) (ice-9 guile)))
+
+
+
+;;; {Simple Debugging Tools}
+;;
+
+;; peek takes any number of arguments, writes them to the
+;; current ouput port, and returns the last argument.
+;; It is handy to wrap around an expression to look at
+;; a value each time is evaluated, e.g.:
+;;
+;; (+ 10 (troublesome-fn))
+;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
+;;
+
+(define (peek . stuff)
+ (newline)
+ (display ";;; ")
+ (write stuff)
+ (newline)
+ (car (last-pair stuff)))
+
+(define pk peek)
+
+
+
+
+;;; {Trivial Functions}
+;;;
+
+(define (id x) x)
+(define (1+ n) (+ n 1))
+(define (-1+ n) (+ n -1))
+(define 1- -1+)
+(define return-it noop)
+(define (and=> value procedure) (and value (procedure value)))
+(define (make-hash-table k) (make-vector k '()))
+
+;;; apply-to-args is functionally redunant with apply and, worse,
+;;; is less general than apply since it only takes two arguments.
+;;;
+;;; On the other hand, apply-to-args is a syntacticly convenient way to
+;;; perform binding in many circumstances when the "let" family of
+;;; of forms don't cut it. E.g.:
+;;;
+;;; (apply-to-args (return-3d-mouse-coords)
+;;; (lambda (x y z)
+;;; ...))
+;;;
+
+(define (apply-to-args args fn) (apply fn args))
+
+
+;;; {Integer Math}
+;;;
+
+(define (ipow-by-squaring x k acc proc)
+ (cond ((zero? k) acc)
+ ((= 1 k) (proc acc x))
+ (else (ipow-by-squaring (proc x x)
+ (quotient k 2)
+ (if (even? k) acc (proc acc x))
+ proc))))
+
+(define string-character-length string-length)
+
+
+
+;; A convenience function for combining flag bits. Like logior, but
+;; handles the cases of 0 and 1 arguments.
+;;
+(define (flags . args)
+ (cond
+ ((null? args) 0)
+ ((null? (cdr args)) (car args))
+ (else (apply logior args))))
+
+
+;;; {Multiple return values}
+
+(define *values-rtd*
+ (make-record-type "values"
+ '(values)))
+
+(define values
+ (let ((make-values (record-constructor *values-rtd*)))
+ (lambda x
+ (if (and (not (null? x))
+ (null? (cdr x)))
+ (car x)
+ (make-values x)))))
+
+(define call-with-values
+ (let ((access-values (record-accessor *values-rtd* 'values))
+ (values-predicate? (record-predicate *values-rtd*)))
+ (lambda (producer consumer)
+ (let ((result (producer)))
+ (if (values-predicate? result)
+ (apply consumer (access-values result))
+ (consumer result))))))
+
+
+
+;;; {and-map and or-map}
+;;;
+;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst.
+;;;
+
+;; and-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or f returns #f.
+;; If returning early, return #f. Otherwise, return the last value returned
+;; by f. If f has never been called because l is empty, return #t.
+;;
+(define (and-map f lst)
+ (let loop ((result #t)
+ (l lst))
+ (and result
+ (or (and (null? l)
+ result)
+ (loop (f (car l)) (cdr l))))))
+
+;; or-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or while f returns #f.
+;; If returning early, return the return value of f.
+;;
+(define (or-map f lst)
+ (let loop ((result #f)
+ (l lst))
+ (or result
+ (and (not (null? l))
+ (loop (f (car l)) (cdr l))))))
+
+
+;;; {Booleans}
+;;;
+
+(define (->bool x) (not (not x)))
+
+
+;;; {Load Paths}
+;;;
+
+;;; Here for backward compatability
+;;
+(define scheme-file-suffix (lambda () ".scm"))
+
+(define (in-vicinity vicinity file)
+ (let ((tail (let ((len (string-length vicinity)))
+ (if (zero? len)
+ #f
+ (string-ref vicinity (- len 1))))))
+ (string-append vicinity
+ (if (or (not tail)
+ (eq? tail #\/))
+ ""
+ "/")
+ file)))
+
+
+;;; {Help for scm_shell}
+;;; The argument-processing code used by Guile-based shells generates
+;;; Scheme code based on the argument list. This page contains help
+;;; functions for the code it generates.
+
+(define (command-line) (program-arguments))
+
+;; This is mostly for the internal use of the code generated by
+;; scm_compile_shell_switches.
+(define (load-user-init)
+ (define (has-init? dir)
+ (let ((path (in-vicinity dir ".guile")))
+ (catch 'system-error
+ (lambda ()
+ (let ((stats (stat path)))
+ (if (not (eq? (stat:type stats) 'directory))
+ path)))
+ (lambda dummy #f))))
+ (let ((path (or (has-init? (or (getenv "HOME") "/"))
+ (has-init? (passwd:dir (getpw (getuid)))))))
+ (if path (primitive-load path))))
+
+
+
+;;; {Reader Extensions}
+;;;
+
+;;; Reader code for various "#c" forms.
+;;;
+
+;;; Parse the portion of a #/ list that comes after the first slash.
+(define (read-path-list-notation slash port)
+ (letrec
+
+ ;; Is C a delimiter?
+ ((delimiter? (lambda (c) (or (eof-object? c)
+ (char-whitespace? c)
+ (string-index "()\";" c))))
+
+ ;; Read and return one component of a path list.
+ (read-component
+ (lambda ()
+ (let loop ((reversed-chars '()))
+ (let ((c (peek-char port)))
+ (if (or (delimiter? c)
+ (char=? c #\/))
+ (string->symbol (list->string (reverse reversed-chars)))
+ (loop (cons (read-char port) reversed-chars))))))))
+
+ ;; Read and return a path list.
+ (let loop ((reversed-path (list (read-component))))
+ (let ((c (peek-char port)))
+ (if (and (char? c) (char=? c #\/))
+ (begin
+ (read-char port)
+ (loop (cons (read-component) reversed-path)))
+ (reverse reversed-path))))))
+
+(define (read-path-list-notation-warning slash port)
+ (if (not (getenv "GUILE_HUSH"))
+ (begin
+ (display "warning: obsolete `#/' list notation read from "
+ (current-error-port))
+ (display (port-filename port) (current-error-port))
+ (display "; see guile-core/NEWS." (current-error-port))
+ (newline (current-error-port))
+ (display " Set the GUILE_HUSH environment variable to disable this warning."
+ (current-error-port))
+ (newline (current-error-port))))
+ (read-hash-extend #\/ read-path-list-notation)
+ (read-path-list-notation slash port))
+
+
+(read-hash-extend #\' (lambda (c port)
+ (read port)))
+(read-hash-extend #\. (lambda (c port)
+ (eval (read port) (the-environment))))
+
+(if (feature? 'array)
+ (begin
+ (let ((make-array-proc (lambda (template)
+ (lambda (c port)
+ (read:uniform-vector template port)))))
+ (for-each (lambda (char template)
+ (read-hash-extend char
+ (make-array-proc template)))
+ '(#\b #\a #\u #\e #\s #\i #\c #\y #\h)
+ '(#t #\a 1 -1 1.0 1/3 0+i #\nul s)))
+ (let ((array-proc (lambda (c port)
+ (read:array c port))))
+ (for-each (lambda (char) (read-hash-extend char array-proc))
+ '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))))
+
+;; pushed to the beginning of the alist since it's used more than the
+;; others at present.
+(read-hash-extend #\/ read-path-list-notation-warning)
+
+(define (read:array digit port)
+ (define chr0 (char->integer #\0))
+ (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
+ (if (char-numeric? (peek-char port))
+ (readnum (+ (* 10 val)
+ (- (char->integer (read-char port)) chr0)))
+ val)))
+ (prot (if (eq? #\( (peek-char port))
+ '()
+ (let ((c (read-char port)))
+ (case c ((#\b) #t)
+ ((#\a) #\a)
+ ((#\u) 1)
+ ((#\e) -1)
+ ((#\s) 1.0)
+ ((#\i) 1/3)
+ ((#\c) 0+i)
+ (else (error "read:array unknown option " c)))))))
+ (if (eq? (peek-char port) #\()
+ (list->uniform-array rank prot (read port))
+ (error "read:array list not found"))))
+
+(define (read:uniform-vector proto port)
+ (if (eq? #\( (peek-char port))
+ (list->uniform-array 1 proto (read port))
+ (error "read:uniform-vector list not found")))
+
+
+;;; {IOTA functions: generating lists of numbers}
+
+(define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '()))
+(define (iota n) (reverse! (reverse-iota n)))
+
+
+;;; {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)))
+
+
diff --git a/ice-9/modules.scm b/ice-9/modules.scm
new file mode 100644
index 000000000..630a6e697
--- /dev/null
+++ b/ice-9/modules.scm
@@ -0,0 +1,82 @@
+;;; this is an add-on module for those who want to "load" the module
+;;; system.
+
+
+;; load the standard module system and add the module which exports
+;; the module configuration language to the current module's import
+;; list
+(eval
+ `(letrec (
+
+
+ ; return #f if module system
+ ; has already been loaded
+ (load-module-system
+
+ (let (
+ (load-sys-modules
+ (lambda (repl-env)
+ (if (not (environment-bound? (module-registry) 'ice-9/config))
+ (begin
+ (eval '(make-guile-module) repl-env)
+ (eval '(make-repl-module) repl-env)
+ (eval '(make-user-module) repl-env)
+ (let (
+ (ice-9/config (eval '(make-config-module) repl-env)))
+ (primitive-load-path "ice-9/config.scm" (vector-ref ice-9/config 0))
+ #t))
+ #f))))
+
+ (lambda ()
+ ; the code that creates system
+ ; modules comes from the repl
+ ; module.
+
+ (if (not (environment-bound? (module-registry) 'ice-9/repl))
+
+ (let* (
+ (import (make-interface-environment (list (cons (scheme-guile-environment 2) #t))))
+ (eval-env (make-eval-environment (make-leaf-environment) import)))
+ (primitive-load-path "ice-9/repl.scm" eval-env)
+ (load-sys-modules eval-env))
+ (let* (
+ (repl-module (environment-ref (module-registry) 'ice-9/repl))
+ (eval-env (vector-ref repl-module 0)))
+ (load-sys-modules eval-env))))))
+
+ ; fix current interface
+ (set-new-interface
+ (lambda (current-interface-env)
+ (let (
+ (guile-export (vector-ref (environment-ref (module-registry) 'ice-9/guile) 1))
+ (config-export (vector-ref (environment-ref (module-registry) 'ice-9/config) 1)))
+
+ (interface-environment-set-interface!
+ current-interface-env
+ (list (cons config-export #f) (cons guile-export #f))))))
+
+
+ ; append config-export to
+ ; current interface
+ (append-interface
+ (lambda (current-interface-env)
+ (let (
+ (import-interface (interface-environment-interface current-interface-env))
+ (config-export (vector-ref (environment-ref (module-registry) 'ice-9/config) 1)))
+
+ (if (not (assq config-export import-interface))
+ (interface-environment-set-interface!
+ current-interface-env
+ (cons (cons config-export #t) import-interface)))))))
+
+ (let* (
+ (current-eval-env ,(the-environment))
+ (current-interface-env (eval-environment-imported current-eval-env)))
+
+ (if (load-module-system)
+ (set-new-interface current-interface-env)
+ (append-interface current-interface-env))))
+
+ (scheme-guile-environment 2))
+
+
diff --git a/ice-9/options.scm b/ice-9/options.scm
new file mode 100644
index 000000000..8bc3e3fe7
--- /dev/null
+++ b/ice-9/options.scm
@@ -0,0 +1,223 @@
+(define-module (ice-9 options) :use-module (ice-9 defmacro))
+;;; {Command Line Options}
+;;;
+
+(define (get-option argv kw-opts kw-args return)
+ (cond
+ ((null? argv)
+ (return #f #f argv))
+
+ ((or (not (eq? #\- (string-ref (car argv) 0)))
+ (eq? (string-length (car argv)) 1))
+ (return 'normal-arg (car argv) (cdr argv)))
+
+ ((eq? #\- (string-ref (car argv) 1))
+ (let* ((kw-arg-pos (or (string-index (car argv) #\=)
+ (string-length (car argv))))
+ (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
+ (kw-opt? (member kw kw-opts))
+ (kw-arg? (member kw kw-args))
+ (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
+ (substring (car argv)
+ (+ kw-arg-pos 1)
+ (string-length (car argv))))
+ (and kw-arg?
+ (begin (set! argv (cdr argv)) (car argv))))))
+ (if (or kw-opt? kw-arg?)
+ (return kw arg (cdr argv))
+ (return 'usage-error kw (cdr argv)))))
+
+ (else
+ (let* ((char (substring (car argv) 1 2))
+ (kw (symbol->keyword char)))
+ (cond
+
+ ((member kw kw-opts)
+ (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+ (new-argv (if (= 0 (string-length rest-car))
+ (cdr argv)
+ (cons (string-append "-" rest-car) (cdr argv)))))
+ (return kw #f new-argv)))
+
+ ((member kw kw-args)
+ (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+ (arg (if (= 0 (string-length rest-car))
+ (cadr argv)
+ rest-car))
+ (new-argv (if (= 0 (string-length rest-car))
+ (cddr argv)
+ (cdr argv))))
+ (return kw arg new-argv)))
+
+ (else (return 'usage-error kw argv)))))))
+
+(define (for-next-option proc argv kw-opts kw-args)
+ (let loop ((argv argv))
+ (get-option argv kw-opts kw-args
+ (lambda (opt opt-arg argv)
+ (and opt (proc opt opt-arg argv loop))))))
+
+(define (display-usage-report kw-desc)
+ (for-each
+ (lambda (kw)
+ (or (eq? (car kw) #t)
+ (eq? (car kw) 'else)
+ (let* ((opt-desc kw)
+ (help (cadr opt-desc))
+ (opts (car opt-desc))
+ (opts-proper (if (string? (car opts)) (cdr opts) opts))
+ (arg-name (if (string? (car opts))
+ (string-append "<" (car opts) ">")
+ ""))
+ (left-part (string-append
+ (with-output-to-string
+ (lambda ()
+ (map (lambda (x) (display (keyword-symbol x)) (display " "))
+ opts-proper)))
+ arg-name))
+ (middle-part (if (and (< (string-length left-part) 30)
+ (< (string-length help) 40))
+ (make-string (- 30 (string-length left-part)) #\ )
+ "\n\t")))
+ (display left-part)
+ (display middle-part)
+ (display help)
+ (newline))))
+ kw-desc))
+
+
+
+(define (transform-usage-lambda cases)
+ (let* ((raw-usage (delq! 'else (map car cases)))
+ (usage-sans-specials (map (lambda (x)
+ (or (and (not (list? x)) x)
+ (and (symbol? (car x)) #t)
+ (and (boolean? (car x)) #t)
+ x))
+ raw-usage))
+ (usage-desc (delq! #t usage-sans-specials))
+ (kw-desc (map car usage-desc))
+ (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
+ (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
+ (transmogrified-cases (map (lambda (case)
+ (cons (let ((opts (car case)))
+ (if (or (boolean? opts) (eq? 'else opts))
+ opts
+ (cond
+ ((symbol? (car opts)) opts)
+ ((boolean? (car opts)) opts)
+ ((string? (caar opts)) (cdar opts))
+ (else (car opts)))))
+ (cdr case)))
+ cases)))
+ `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
+ (lambda (%argv)
+ (let %next-arg ((%argv %argv))
+ (get-option %argv
+ ',kw-opts
+ ',kw-args
+ (lambda (%opt %arg %new-argv)
+ (case %opt
+ ,@ transmogrified-cases))))))))
+
+
+;;; {Run-time options}
+
+((let* ((names '((eval-options-interface
+ (eval-options eval-enable eval-disable)
+ (eval-set!))
+
+ (debug-options-interface
+ (debug-options debug-enable debug-disable)
+ (debug-set!))
+
+ (evaluator-traps-interface
+ (traps trap-enable trap-disable)
+ (trap-set!))
+
+ (read-options-interface
+ (read-options read-enable read-disable)
+ (read-set!))
+
+ (print-options-interface
+ (print-options print-enable print-disable)
+ (print-set!))
+
+ (readline-options-interface
+ (readline-options readline-enable readline-disable)
+ (readline-set!))
+ ))
+ (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 follows 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
+ (apply append
+ (map (lambda (group)
+ (let ((interface (car group)))
+ (append (map (lambda (name constructor)
+ `(define ,name
+ ,(constructor interface)))
+ (cadr group)
+ (list make-options
+ make-enable
+ make-disable))
+ (map (lambda (name constructor)
+ `(defmacro ,name
+ ,@(constructor interface)))
+ (caddr group)
+ (list make-set!)))))
+ names)))))))
+
+(export eval-options eval-enable eval-disable eval-set! debug-options
+debug-enable debug-disable traps trap-enable trap-disable trap-set!
+read-enable read-disable read-set! print-enable print-disable
+print-set! readline-options readline-enable readline-disable
+readline-set!)
+
diff --git a/ice-9/posix.scm b/ice-9/posix.scm
index 9698a0b8a..14ce238da 100644
--- a/ice-9/posix.scm
+++ b/ice-9/posix.scm
@@ -1,70 +1,190 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1999 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
-;;;;
-
-(define (stat:dev f) (vector-ref f 0))
-(define (stat:ino f) (vector-ref f 1))
-(define (stat:mode f) (vector-ref f 2))
-(define (stat:nlink f) (vector-ref f 3))
-(define (stat:uid f) (vector-ref f 4))
-(define (stat:gid f) (vector-ref f 5))
-(define (stat:rdev f) (vector-ref f 6))
-(define (stat:size f) (vector-ref f 7))
-(define (stat:atime f) (vector-ref f 8))
-(define (stat:mtime f) (vector-ref f 9))
-(define (stat:ctime f) (vector-ref f 10))
-(define (stat:blksize f) (vector-ref f 11))
-(define (stat:blocks f) (vector-ref f 12))
-
-;; derived from stat mode.
-(define (stat:type f) (vector-ref f 13))
-(define (stat:perms f) (vector-ref f 14))
-
-(define (passwd:name obj) (vector-ref obj 0))
-(define (passwd:passwd obj) (vector-ref obj 1))
-(define (passwd:uid obj) (vector-ref obj 2))
-(define (passwd:gid obj) (vector-ref obj 3))
-(define (passwd:gecos obj) (vector-ref obj 4))
-(define (passwd:dir obj) (vector-ref obj 5))
-(define (passwd:shell obj) (vector-ref obj 6))
-
-(define (group:name obj) (vector-ref obj 0))
-(define (group:passwd obj) (vector-ref obj 1))
-(define (group:gid obj) (vector-ref obj 2))
-(define (group:mem obj) (vector-ref obj 3))
-
-(define (utsname:sysname obj) (vector-ref obj 0))
-(define (utsname:nodename obj) (vector-ref obj 1))
-(define (utsname:release obj) (vector-ref obj 2))
-(define (utsname:version obj) (vector-ref obj 3))
-(define (utsname:machine obj) (vector-ref obj 4))
-
-(define (getpwent) (getpw))
-(define (setpwent) (setpw #t))
-(define (endpwent) (setpw))
-
-(define (getpwnam name) (getpw name))
-(define (getpwuid uid) (getpw uid))
-
-(define (getgrent) (getgr))
-(define (setgrent) (setgr #f))
-(define (endgrent) (setgr))
-
-(define (getgrnam name) (getgr name))
-(define (getgrgid id) (getgr id))
+(module (ice-9 posix)
+ (open (ice-9 guile)
+ ((ice-9 config) define-public)))
+
+
+;;; {Non-polymorphic versions of POSIX functions}
+
+(define-public (getgrnam name) (getgr name))
+(define-public (getgrgid id) (getgr id))
+(define-public (gethostbyaddr addr) (gethost addr))
+(define-public (gethostbyname name) (gethost name))
+(define-public (getnetbyaddr addr) (getnet addr))
+(define-public (getnetbyname name) (getnet name))
+(define-public (getprotobyname name) (getproto name))
+(define-public (getprotobynumber addr) (getproto addr))
+(define-public (getpwnam name) (getpw name))
+(define-public (getpwuid uid) (getpw uid))
+(define-public (getservbyname name proto) (getserv name proto))
+(define-public (getservbyport port proto) (getserv port proto))
+(define-public (endgrent) (setgr))
+(define-public (endhostent) (sethost))
+(define-public (endnetent) (setnet))
+(define-public (endprotoent) (setproto))
+(define-public (endpwent) (setpw))
+(define-public (endservent) (setserv))
+(define-public (getgrent) (getgr))
+(define-public (gethostent) (gethost))
+(define-public (getnetent) (getnet))
+(define-public (getprotoent) (getproto))
+(define-public (getpwent) (getpw))
+(define-public (getservent) (getserv))
+(define-public (reopen-file . args) (apply freopen args))
+(define-public (setgrent) (setgr #f))
+(define-public (sethostent) (sethost #t))
+(define-public (setnetent) (setnet #t))
+(define-public (setprotoent) (setproto #t))
+(define-public (setpwent) (setpw #t))
+(define-public (setservent) (setserv #t))
+
+(define-public (passwd:name obj) (vector-ref obj 0))
+(define-public (passwd:passwd obj) (vector-ref obj 1))
+(define-public (passwd:uid obj) (vector-ref obj 2))
+(define-public (passwd:gid obj) (vector-ref obj 3))
+(define-public (passwd:gecos obj) (vector-ref obj 4))
+(define-public (passwd:dir obj) (vector-ref obj 5))
+(define-public (passwd:shell obj) (vector-ref obj 6))
+
+(define-public (group:name obj) (vector-ref obj 0))
+(define-public (group:passwd obj) (vector-ref obj 1))
+(define-public (group:gid obj) (vector-ref obj 2))
+(define-public (group:mem obj) (vector-ref obj 3))
+
+(define-public (hostent:name obj) (vector-ref obj 0))
+(define-public (hostent:aliases obj) (vector-ref obj 1))
+(define-public (hostent:addrtype obj) (vector-ref obj 2))
+(define-public (hostent:length obj) (vector-ref obj 3))
+(define-public (hostent:addr-list obj) (vector-ref obj 4))
+
+(define-public (netent:name obj) (vector-ref obj 0))
+(define-public (netent:aliases obj) (vector-ref obj 1))
+(define-public (netent:addrtype obj) (vector-ref obj 2))
+(define-public (netent:net obj) (vector-ref obj 3))
+
+(define-public (protoent:name obj) (vector-ref obj 0))
+(define-public (protoent:aliases obj) (vector-ref obj 1))
+(define-public (protoent:proto obj) (vector-ref obj 2))
+
+(define-public (servent:name obj) (vector-ref obj 0))
+(define-public (servent:aliases obj) (vector-ref obj 1))
+(define-public (servent:port obj) (vector-ref obj 2))
+(define-public (servent:proto obj) (vector-ref obj 3))
+
+(define-public (sockaddr:fam obj) (vector-ref obj 0))
+(define-public (sockaddr:path obj) (vector-ref obj 1))
+(define-public (sockaddr:addr obj) (vector-ref obj 1))
+(define-public (sockaddr:port obj) (vector-ref obj 2))
+
+(define-public (utsname:sysname obj) (vector-ref obj 0))
+(define-public (utsname:nodename obj) (vector-ref obj 1))
+(define-public (utsname:release obj) (vector-ref obj 2))
+(define-public (utsname:version obj) (vector-ref obj 3))
+(define-public (utsname:machine obj) (vector-ref obj 4))
+
+(define-public (tm:sec obj) (vector-ref obj 0))
+(define-public (tm:min obj) (vector-ref obj 1))
+(define-public (tm:hour obj) (vector-ref obj 2))
+(define-public (tm:mday obj) (vector-ref obj 3))
+(define-public (tm:mon obj) (vector-ref obj 4))
+(define-public (tm:year obj) (vector-ref obj 5))
+(define-public (tm:wday obj) (vector-ref obj 6))
+(define-public (tm:yday obj) (vector-ref obj 7))
+(define-public (tm:isdst obj) (vector-ref obj 8))
+(define-public (tm:gmtoff obj) (vector-ref obj 9))
+(define-public (tm:zone obj) (vector-ref obj 10))
+
+(define-public (set-tm:sec obj val) (vector-set! obj 0 val))
+(define-public (set-tm:min obj val) (vector-set! obj 1 val))
+(define-public (set-tm:hour obj val) (vector-set! obj 2 val))
+(define-public (set-tm:mday obj val) (vector-set! obj 3 val))
+(define-public (set-tm:mon obj val) (vector-set! obj 4 val))
+(define-public (set-tm:year obj val) (vector-set! obj 5 val))
+(define-public (set-tm:wday obj val) (vector-set! obj 6 val))
+(define-public (set-tm:yday obj val) (vector-set! obj 7 val))
+(define-public (set-tm:isdst obj val) (vector-set! obj 8 val))
+(define-public (set-tm:gmtoff obj val) (vector-set! obj 9 val))
+(define-public (set-tm:zone obj val) (vector-set! obj 10 val))
+
+(define-public (tms:clock obj) (vector-ref obj 0))
+(define-public (tms:utime obj) (vector-ref obj 1))
+(define-public (tms:stime obj) (vector-ref obj 2))
+(define-public (tms:cutime obj) (vector-ref obj 3))
+(define-public (tms:cstime obj) (vector-ref obj 4))
+
+(define-public (file-position . args) (apply ftell args))
+(define-public (file-set-position . args) (apply fseek args))
+
+(define-public (open-input-pipe command) (open-pipe command OPEN_READ))
+(define-public (open-output-pipe command) (open-pipe command OPEN_WRITE))
+
+(define-public (move->fdes fd/port fd)
+ (cond ((integer? fd/port)
+ (dup->fdes fd/port fd)
+ (close fd/port)
+ fd)
+ (else
+ (primitive-move->fdes fd/port fd)
+ (set-port-revealed! fd/port 1)
+ fd/port)))
+
+(define-public (release-port-handle port)
+ (let ((revealed (port-revealed port)))
+ (if (> revealed 0)
+ (set-port-revealed! port (- revealed 1)))))
+
+(define-public (dup->port port/fd mode . maybe-fd)
+ (let ((port (fdopen (apply dup->fdes port/fd maybe-fd)
+ mode)))
+ (if (pair? maybe-fd)
+ (set-port-revealed! port 1))
+ port))
+
+(define-public (dup->inport port/fd . maybe-fd)
+ (apply dup->port port/fd "r" maybe-fd))
+
+(define-public (dup->outport port/fd . maybe-fd)
+ (apply dup->port port/fd "w" maybe-fd))
+
+(define-public (dup port/fd . maybe-fd)
+ (if (integer? port/fd)
+ (apply dup->fdes port/fd maybe-fd)
+ (apply dup->port port/fd (port-mode port/fd) maybe-fd)))
+
+(define-public (duplicate-port port modes)
+ (dup->port port modes))
+
+(define-public (fdes->inport fdes)
+ (let loop ((rest-ports (fdes->ports fdes)))
+ (cond ((null? rest-ports)
+ (let ((result (fdopen fdes "r")))
+ (set-port-revealed! result 1)
+ result))
+ ((input-port? (car rest-ports))
+ (set-port-revealed! (car rest-ports)
+ (+ (port-revealed (car rest-ports)) 1))
+ (car rest-ports))
+ (else
+ (loop (cdr rest-ports))))))
+
+(define-public (fdes->outport fdes)
+ (let loop ((rest-ports (fdes->ports fdes)))
+ (cond ((null? rest-ports)
+ (let ((result (fdopen fdes "w")))
+ (set-port-revealed! result 1)
+ result))
+ ((output-port? (car rest-ports))
+ (set-port-revealed! (car rest-ports)
+ (+ (port-revealed (car rest-ports)) 1))
+ (car rest-ports))
+ (else
+ (loop (cdr rest-ports))))))
+
+(define-public (port->fdes port)
+ (set-port-revealed! port (+ (port-revealed port) 1))
+ (fileno port))
+
+(define-public (setenv name value)
+ (if value
+ (putenv (string-append name "=" value))
+ (putenv name)))
+
diff --git a/ice-9/provide.scm b/ice-9/provide.scm
new file mode 100644
index 000000000..a5d7a881c
--- /dev/null
+++ b/ice-9/provide.scm
@@ -0,0 +1,13 @@
+;;; {Features}
+;;
+(module (ice-9 provide)
+ (open (ice-9 guile))
+ (export provide feature?))
+
+(define (provide sym)
+ (if (not (memq sym *features*))
+ (set! *features* (cons sym *features*))))
+
+(define (feature? feature)
+ (and (memq feature *features*) #t))
+
diff --git a/ice-9/repl.scm b/ice-9/repl.scm
new file mode 100644
index 000000000..3a09045e2
--- /dev/null
+++ b/ice-9/repl.scm
@@ -0,0 +1,478 @@
+;;; This is the module (ice-9 repl).
+;;;
+
+;; the current module
+(define make-repl-module
+ (lambda ()
+ (let ((ice-9/repl (and (environment-bound? (module-registry) 'ice-9/repl)
+ (environment-ref (module-registry) 'ice-9/repl))))
+ (if (not ice-9/repl)
+ (let* (
+ (eval (the-environment))
+ (export (make-interface-environment (list (list eval 'top-repl))))
+ (protect (make-interface-environment (list (list eval 'top-repl 'save-stack 'abort-hook))))
+ (ice-9/repl (vector eval export protect 'ice-9/ 'ice-9/repl)))
+ (environment-define (module-registry) 'ice-9/repl ice-9/repl)
+ (hashq-set! (environment-module-hash) eval ice-9/repl))
+ ice-9/repl))))
+
+;; the guile module
+(define make-guile-module
+ (lambda ()
+ (let ((ice-9/guile (and (environment-bound? (module-registry) 'ice-9/guile)
+ (environment-ref (module-registry) 'ice-9/guile))))
+
+ (if (not ice-9/guile)
+ (let* (
+ (eval (scheme-guile-environment 2))
+ (export (make-interface-environment (list (cons eval #t))))
+ (protect (make-interface-environment (list (cons eval #t))))
+ (ice-9/guile (vector eval export protect 'ice-9/ 'ice-9/guile)))
+ (environment-define (module-registry) 'ice-9/guile ice-9/guile)
+ (hashq-set! (environment-module-hash) eval ice-9/guile))
+ ice-9/guile))))
+
+(define make-user-module
+ (lambda ()
+ (let ((user/guile (and (environment-bound? (module-registry) 'user/guile)
+ (environment-ref (module-registry) 'user/guile))))
+
+ (if (not user/guile)
+ (let* (
+ (eval-env (guile-user-environment 2))
+ (export (make-interface-environment (list (cons eval-env #t))))
+ (protect (make-interface-environment (list (cons eval-env #t))))
+ (user/guile (vector eval-env export protect 'user/ 'user/guile)))
+
+ (environment-define (module-registry) 'user/guile user/guile)
+ (hashq-set! (environment-module-hash) eval-env user/guile))
+ user/guile))))
+
+(define make-config-module
+ (lambda ()
+ (let ((ice-9/config (and (environment-bound? (module-registry) 'ice-9/config)
+ (environment-ref (module-registry) 'ice-9/config))))
+
+ (if (not ice-9/config)
+ (let* ((import (make-interface-environment (list (cons (scheme-guile-environment 2) #t))))
+ (eval-env (make-eval-environment (make-leaf-environment) import))
+ (export (make-interface-environment (list (cons eval-env #t))))
+ (protect (make-interface-environment (list (cons eval-env #t))))
+ (ice-9/config (vector eval-env export protect 'ice-9/ 'ice-9/config)))
+
+ (environment-define (module-registry) 'ice-9/config ice-9/config)
+ (hashq-set! (environment-module-hash) eval-env ice-9/config))
+ ice-9/config))))
+
+
+
+
+;;; some more redundancy
+
+(define (module-name module) (vector-ref module 4))
+(define (module-eval-environment module) (vector-ref module 0))
+
+(define (run-hooks hook)
+ (if (and (pair? hook) (eq? (car hook) 'hook))
+ (run-hook hook)
+ (for-each (lambda (thunk) (thunk)) hook)))
+
+
+
+;;; {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 enter-frame-handler default-lazy-handler)
+(define apply-frame-handler default-lazy-handler)
+(define exit-frame-handler default-lazy-handler)
+
+(define (lazy-handler-dispatch key . args)
+ (case key
+ ((apply-frame)
+ (apply apply-frame-handler key args))
+ ((exit-frame)
+ (apply exit-frame-handler key args))
+ ((enter-frame)
+ (apply enter-frame-handler key args))
+ (else
+ (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)
+ (force-output)
+ (set! status (car 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)
+ (display "ABORT: " (current-error-port))
+ (write args (current-error-port))
+ (newline (current-error-port))
+ (if interactive
+ (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.\n"
+ (current-error-port))
+ (set! has-shown-debugger-hint? #t)))
+ (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 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 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 (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 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 () (p (e (r))))))5
+
+(define (gc-run-time)
+ (cdr (assq 'gc-time-taken (gc-stats))))
+
+(define before-read-hook (make-hook))
+(define after-read-hook (make-hook))
+
+;;; 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 module)
+ (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 (string-append (module-name module) "> " )))
+ (repl-reader prompt))))
+
+ (run-hooks after-read-hook)
+ (if (eof-object? val)
+ (begin
+ (repl-report-start-timing)
+ (if scm-repl-verbose
+ (begin
+ (newline)
+ (display ";;; EOF -- quitting")
+ (newline)))
+ (throw 'quit #f)))
+
+ ;; As described in R4RS, the READ procedure updates the
+ ;; port to point to the first characetr 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.
+ (consume-trailing-whitespace)
+
+ val)))
+
+ (-eval (lambda (sourc)
+ (repl-report-start-timing)
+ (start-stack 'repl-stack (eval sourc (module-eval-environment module)))))
+
+ (-print (lambda (result)
+ (if (not scm-repl-silent)
+ (begin
+ (if (or scm-repl-print-unspecified
+ (not (unspecified? result)))
+ (begin
+ (write result)
+ (newline)))
+ (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))))
+
+
+;; this is just (scm-style-repl) with a wrapper to install and remove
+;; signal handlers. Every module may have exactly one repl.
+
+
+(define (top-repl module)
+ (let ((old-handlers #f)
+ (signals `((,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)
+ (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 ()
+ (scm-style-repl module))
+
+
+ ;; 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)))))
+
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
+
+
+;; now provide a function which starts the repl
+(define start
+ (lambda ()
+ (make-guile-module)
+ (make-repl-module)
+ (let ((user/guile (make-user-module)))
+
+ (set-interaction-environment! (vector-ref user/guile 0))
+
+ (let (
+ (ret-val (top-repl user/guile))
+
+ (start-module-system
+ (lambda ()
+ ;; create (ice-9 config) and re-start the repl in there
+ (let* ((ice-9/config (make-config-module))
+ (eval-env (vector-ref ice-9/config 0)))
+ (primitive-load-path "ice-9/config.scm" eval-env)
+ (eval '(start) eval-env)))))
+
+ (if (and (eqv? #f ret-val) (isatty? (current-input-port)))
+ (begin
+ (newline)
+ (set! ret-val (start-module-system))))
+
+ (or ret-val 0)))))
+
+
diff --git a/ice-9/run-test.scm b/ice-9/run-test.scm
new file mode 100644
index 000000000..44c73d95f
--- /dev/null
+++ b/ice-9/run-test.scm
@@ -0,0 +1,5 @@
+(define %library-dir
+ (lambda () (string-append (%package-data-dir) "/" (version))))
+
+(chdir (string-append (%library-dir) "/ice-9"))
+(define-module (ice-9 run-test) :use-module (ice-9 test)) \ No newline at end of file
diff --git a/ice-9/structs.scm b/ice-9/structs.scm
new file mode 100644
index 000000000..760e61d8e
--- /dev/null
+++ b/ice-9/structs.scm
@@ -0,0 +1,127 @@
+(module (ice-9 structs)
+
+ (export record-type? make-record-type record-type-name record-type-fields record-constructor record-predicate
+ record-accessor record-modifier record? record-type-descriptor)
+
+ (open (ice-9 provide) (ice-9 symbols) (ice-9 lists) (ice-9 guile)))
+
+;;; {Structs}
+
+(define (struct-layout s)
+ (struct-ref (struct-vtable s) vtable-index-layout))
+
+
+;;; {Records}
+;;;
+
+;; Printing records: by default, records are printed as
+;;
+;; #<type-name field1: val1 field2: val2 ...>
+;;
+;; You can change that by giving a custom printing function to
+;; MAKE-RECORD-TYPE (after the list of field symbols). This function
+;; will be called like
+;;
+;; (<printer> object port)
+;;
+;; It should print OBJECT to PORT.
+
+(define (inherit-print-state old-port new-port)
+ (if (pair? old-port)
+ (cons (if (pair? new-port) (car new-port) new-port)
+ (cdr old-port))
+ new-port))
+
+;; 0: type-name, 1: fields
+(define record-type-vtable
+ (make-vtable-vtable "prpr" 0
+ (lambda (s p)
+ (cond ((eq? s record-type-vtable)
+ (display "#<record-type-vtable>" p))
+ (else
+ (display "#<record-type " p)
+ (display (record-type-name s) p)
+ (display ">" p))))))
+
+(define (record-type? obj)
+ (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
+
+(define (make-record-type type-name fields . opt)
+ (let ((printer-fn (and (pair? opt) (car opt))))
+ (let ((struct (make-struct record-type-vtable 0
+ (make-struct-layout
+ (apply symbol-append
+ (map (lambda (f) "pw") fields)))
+ (or printer-fn
+ (lambda (s p)
+ (display "#<" p)
+ (display type-name p)
+ (let loop ((fields fields)
+ (off 0))
+ (cond
+ ((not (null? fields))
+ (display " " p)
+ (display (car fields) p)
+ (display ": " p)
+ (display (struct-ref s off) p)
+ (loop (cdr fields) (+ 1 off)))))
+ (display ">" p)))
+ type-name
+ (copy-tree fields))))
+ ;; Temporary solution: Associate a name to the record type descriptor
+ ;; so that the object system can create a wrapper class for it.
+ (set-struct-vtable-name! struct (if (symbol? type-name)
+ type-name
+ (string->symbol type-name)))
+ struct)))
+
+(define (record-type-name obj)
+ (if (record-type? obj)
+ (struct-ref obj vtable-offset-user)
+ (error 'not-a-record-type obj)))
+
+(define (record-type-fields obj)
+ (if (record-type? obj)
+ (struct-ref obj (+ 1 vtable-offset-user))
+ (error 'not-a-record-type obj)))
+
+(define (record-constructor rtd . opt)
+ (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
+ (eval `(lambda ,field-names
+ (make-struct ',rtd 0 ,@(map (lambda (f)
+ (if (memq f field-names)
+ f
+ #f))
+ (record-type-fields rtd))))
+ (the-environment))))
+
+(define (record-predicate rtd)
+ (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
+
+(define (record-accessor rtd field-name)
+ (let* ((pos (list-index (record-type-fields rtd) field-name)))
+ (if (not pos)
+ (error 'no-such-field field-name))
+ (eval `(lambda (obj)
+ (and (eq? ',rtd (record-type-descriptor obj))
+ (struct-ref obj ,pos))) (the-environment))))
+
+(define (record-modifier rtd field-name)
+ (let* ((pos (list-index (record-type-fields rtd) field-name)))
+ (if (not pos)
+ (error 'no-such-field field-name))
+ (eval `(lambda (obj val)
+ (and (eq? ',rtd (record-type-descriptor obj))
+ (struct-set! obj ,pos val))) (the-environment) )))
+
+
+(define (record? obj)
+ (and (struct? obj) (record-type? (struct-vtable obj))))
+
+(define (record-type-descriptor obj)
+ (if (struct? obj)
+ (struct-vtable obj)
+ (error 'not-a-record obj)))
+
+(provide 'record)
+
diff --git a/ice-9/symbols.scm b/ice-9/symbols.scm
new file mode 100644
index 000000000..cb2cfb504
--- /dev/null
+++ b/ice-9/symbols.scm
@@ -0,0 +1,23 @@
+;;; {Symbols}
+;;;
+(module (ice-9 symbols)
+ (open (ice-9 guile))
+ (export symbol-append list->symbol symbol obarray-symbol-append obarray-gensym))
+
+(define (symbol-append . args)
+ (string->symbol (apply string-append args)))
+
+(define (list->symbol . args)
+ (string->symbol (apply list->string args)))
+
+(define (symbol . args)
+ (string->symbol (apply string args)))
+
+(define (obarray-symbol-append ob . args)
+ (string->obarray-symbol (apply string-append ob args)))
+
+(define (obarray-gensym obarray . opt)
+ (if (null? opt)
+ (gensym "%%gensym" obarray)
+ (gensym (car opt) obarray)))
+
View Lorry Controller Status