;;; installed-scm-file
-;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997, 1998 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
\f
-;;; {and-map, or-map, and map-in-order}
+;;; {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))))))
+
+
+\f
+;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
(and (not (null? l))
(loop (f (car l)) (cdr l))))))
-;; map-in-order
-;;
-;; Like map, but guaranteed to process the list in order.
-;;
-(define (map-in-order fn l)
- (if (null? l)
- '()
- (cons (fn (car l))
- (map-in-order fn (cdr l)))))
-
\f
;;; {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.
+;;;
+(if (not (defined? 'new-add-hook!))
+ (begin
+ (define new-add-hook! add-hook!)
+ (define new-remove-hook! remove-hook!)))
+
(define (run-hooks hook)
- (for-each (lambda (thunk) (thunk)) hook))
+ (if (and (pair? hook) (eq? (car hook) 'hook))
+ (run-hook hook)
+ (for-each (lambda (thunk) (thunk)) hook)))
(define add-hook!
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
- `(let ((thunk ,(caddr exp)))
- (if (not (memq thunk ,(cadr exp)))
- (set! ,(cadr exp)
- (cons thunk ,(cadr exp))))))))
+ (let ((hook (local-eval (cadr exp) env)))
+ (if (and (pair? hook) (eq? (car hook) 'hook))
+ `(new-add-hook! ,@(cdr exp))
+ (begin
+ (display "Warning: Old style hooks\n" (current-error-port))
+ `(let ((thunk ,(caddr exp)))
+ (if (not (memq thunk ,(cadr exp)))
+ (set! ,(cadr exp)
+ (cons thunk ,(cadr exp)))))))))))
(define remove-hook!
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
- `(let ((thunk ,(caddr exp)))
- (if (memq thunk ,(cadr exp))
- (set! ,(cadr exp)
- (delq! thunk ,(cadr exp))))))))
+ (let ((hook (local-eval (cadr exp) env)))
+ (if (and (pair? hook) (eq? (car hook) 'hook))
+ `(new-remove-hook! ,@(cdr exp))
+ (begin
+ (display "Warning: Old style hooks\n" (current-error-port))
+ `(let ((thunk ,(caddr exp)))
+ (set! ,(cadr exp)
+ (delq! thunk ,(cadr exp))))))))))
\f
;;; {Files}
(define set-module-uses! (record-modifier module-type 'uses))
(define module-binder (record-accessor module-type 'binder))
(define set-module-binder! (record-modifier module-type 'binder))
+
+;; NOTE: This binding is used in libguile/modules.c.
(define module-eval-closure (record-accessor module-type 'eval-closure))
+
(define set-module-eval-closure! (record-modifier module-type 'eval-closure))
(define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
;; the-module
-;;
+;;
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define the-module #f)
;; scm:eval-transformer
;;
;; set the current module as viewed by the normalizer.
;;
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (set-current-module m)
(set! the-module m)
(if m
;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (resolve-module name . maybe-autoload)
(let ((full-name (append '(app modules) name)))
(let ((already (local-ref full-name)))
- (or already
- (begin
- (if (or (null? maybe-autoload) (car maybe-autoload))
- (or (try-module-linked name)
- (try-module-autoload name)
- (try-module-dynamic-link name)))
- (make-modules-in (current-module) full-name))))))
+ (or already
+ (begin
+ (if (or (null? maybe-autoload) (car maybe-autoload))
+ (or (try-module-linked name)
+ (try-module-autoload name)
+ (try-module-dynamic-link name)))
+ (make-modules-in (current-module) full-name))))))
(define (beautify-user-module! module)
- (if (not (module-public-interface module))
- (let ((interface (make-module 31)))
- (set-module-name! interface (module-name module))
- (set-module-kind! interface 'interface)
- (set-module-public-interface! module interface)))
+ (let ((interface (module-public-interface module)))
+ (if (or (not interface)
+ (eq? interface module))
+ (let ((interface (make-module 31)))
+ (set-module-name! interface (module-name module))
+ (set-module-kind! interface 'interface)
+ (set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module)))
(set-module-uses! module (append (module-uses module) (list the-scm-module)))))
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (make-modules-in module name)
(if (null? name)
module
(cond
- ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name))))
+ ((module-ref module (car name) #f)
+ => (lambda (m) (make-modules-in m (cdr name))))
(else (let ((m (make-module 31)))
(set-module-kind! m 'directory)
(set-module-name! m (car name))
(error "unrecognized defmodule argument" kws))
(let* ((used-name (cadr kws))
(used-module (resolve-module used-name)))
- (if (not (module-ref used-module '%module-public-interface #f))
+ (if (eq? used-module module)
+ (begin
+ (or (try-module-linked used-name)
+ (try-module-dynamic-link used-name))
+ (loop (cddr kws) reversed-interfaces))
(begin
- ((if %autoloader-developer-mode warn error)
- "no code for module" (module-name used-module))
- (beautify-user-module! used-module)))
- (let ((interface (module-public-interface used-module)))
- (if (not interface)
- (error "missing interface for use-module" used-module))
- (if (eq? keyword 'use-syntax)
- (internal-use-syntax
- (module-ref interface (car (last-pair used-name))
- #f)))
- (loop (cddr kws) (cons interface reversed-interfaces)))))
+ (if (not (module-ref used-module
+ '%module-public-interface
+ #f))
+ (begin
+ ((if %autoloader-developer-mode warn error)
+ "no code for module" (module-name used-module))
+ (beautify-user-module! used-module)))
+ (let ((interface (module-public-interface used-module)))
+ (if (not interface)
+ (error "missing interface for use-module"
+ used-module))
+ (if (eq? keyword 'use-syntax)
+ (internal-use-syntax
+ (module-ref interface (car (last-pair used-name))
+ #f)))
+ (loop (cddr kws)
+ (cons interface reversed-interfaces)))))))
(else
(error "unrecognized defmodule argument" kws))))))
module))
(c-clear-registered-modules)
res))
-(define registered-modules (convert-c-registered-modules #f))
-
+(define registered-modules '())
+
+(define (register-modules dynobj)
+ (set! registered-modules
+ (append! (convert-c-registered-modules dynobj)
+ registered-modules)))
+
(define (init-dynamic-module modname)
+ ;; Register any linked modules which has been registered on the C level
+ (register-modules #f)
(or-map (lambda (modinfo)
(if (equal? (car modinfo) modname)
- (let ((mod (resolve-module modname #f)))
- (save-module-excursion
- (lambda ()
- (set-current-module mod)
- (dynamic-call (cadr modinfo) (caddr modinfo))
- (set-module-public-interface! mod mod)))
+ (begin
(set! registered-modules (delq! modinfo registered-modules))
- #t)
+ (let ((mod (resolve-module modname #f)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module mod)
+ (set-module-public-interface! mod mod)
+ (dynamic-call (cadr modinfo) (caddr modinfo))
+ ))
+ #t))
#f))
registered-modules))
(lambda ()
(let loop ((ln (read-line)))
(cond ((eof-object? ln) #f)
- ((and (>= (string-length ln) 8)
+ ((and (> (string-length ln) 9)
(string=? "dlname='" (substring ln 0 8))
(string-index ln #\' 8))
=>
(in-vicinity libdir (string-append libname ".so")))
(define (link-dynamic-module filename initname)
+ ;; Register any linked modules which has been registered on the C level
+ (register-modules #f)
(let ((dynobj (dynamic-link filename)))
(dynamic-call initname dynobj)
- (set! registered-modules
- (append! (convert-c-registered-modules dynobj)
- registered-modules))))
+ (register-modules dynobj)))
(define (try-module-linked module-name)
(init-dynamic-module module-name))
(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)
(else
(apply default-lazy-handler key args))))
-(define abort-hook '())
+(define abort-hook (make-hook))
;; these definitions are used if running a script.
;; otherwise redefined in error-catching-loop.
;; (set! first #f) above
;;
(lambda ()
- (run-hooks abort-hook)
+ (run-hook abort-hook)
(force-output)
(display "ABORT: " (current-error-port))
(write args (current-error-port))
(apply make-stack #t save-stack id narrowing))))))
(set! stack-saved? #t))))
-(define before-error-hook '())
-(define after-error-hook '())
-(define before-backtrace-hook '())
-(define after-backtrace-hook '())
+(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)
(let ((cep (current-error-port)))
(cond ((not (stack? (fluid-ref the-last-stack))))
((memq 'backtrace (debug-options-interface))
- (run-hooks before-backtrace-hook)
+ (run-hook before-backtrace-hook)
(newline cep)
(display-backtrace (fluid-ref the-last-stack) cep)
(newline cep)
- (run-hooks after-backtrace-hook)))
- (run-hooks before-error-hook)
+ (run-hook after-backtrace-hook)))
+ (run-hook before-error-hook)
(apply display-error (fluid-ref the-last-stack) cep args)
- (run-hooks after-error-hook)
+ (run-hook after-error-hook)
(force-output cep)
(throw 'abort key)))
(define (gc-run-time)
(cdr (assq 'gc-time-taken (gc-stats))))
-(define before-read-hook '())
-(define after-read-hook '())
+(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.
(lambda (prompt)
(display prompt)
(force-output)
- (run-hooks before-read-hook)
+ (run-hook before-read-hook)
(read (current-input-port))))
(define (scm-style-repl)
;; trailing newline here, as well as any whitespace
;; before it.
(consume-trailing-whitespace)
- (run-hooks after-read-hook)
+ (run-hook after-read-hook)
(if (eof-object? val)
(begin
(repl-report-start-timing)
(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* (list ,@(map car bindings)) (list ,@(map cadr bindings))
(lambda () ,@body)))
+;;; Environments
+
+(define the-environment
+ (procedure->syntax
+ (lambda (x e)
+ e)))
+
\f
;;; {Macros}
\f
+;;; {Load emacs interface support if emacs option is given.}
+
+(define (load-emacs-interface)
+ (if (memq 'debug-extensions *features*)
+ (debug-enable 'backtrace))
+ (define-module (guile-user) :use-module (ice-9 emacs)))
+
+\f
;;; {I/O functions for Tcl channels (disabled)}
;; (define in-ch (get-standard-channel TCL_STDIN))
;; this is just (scm-style-repl) with a wrapper to install and remove
;; signal handlers.
(define (top-repl)
+
+ ;; Load emacs interface support if emacs option is given.
+ (if (and (module-defined? the-root-module 'use-emacs-interface)
+ use-emacs-interface)
+ (load-emacs-interface))
+
+ ;; Place the user in the guile-user module.
+ (define-module (guile-user))
+
(let ((old-handlers #f)
(signals `((,SIGINT . "User interrupt")
(,SIGFPE . "Arithmetic error")
(not (and (module-defined? the-root-module
'use-emacs-interface)
use-emacs-interface)))
- (let ((read-hook (lambda () (run-hooks before-read-hook))))
+ (let ((read-hook (lambda () (run-hook before-read-hook))))
(set-current-input-port (readline-port))
(set! repl-reader
(lambda (prompt)
(lambda ()
(set-readline-prompt! "")
(set-readline-read-hook! #f)))))))
- (scm-style-repl))
+ (let ((status (scm-style-repl)))
+ (run-hook exit-hook)
+ status))
;; call at exit.
(lambda ()
`(catch #t (lambda () ,expr)
(lambda args #f)))
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
;;; Load readline code into root module if readline primitives are available.
;;;
;;; Ideally, we wouldn't do this until we were sure we were actually
(define-module (guile-user) :use-module (ice-9 threads)))
\f
-;;; {Load emacs interface support if emacs option is given.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (and (module-defined? the-root-module 'use-emacs-interface)
- use-emacs-interface)
- (begin
- (if (memq 'debug-extensions *features*)
- (debug-enable 'backtrace))
- (define-module (guile-user) :use-module (ice-9 emacs))))
-
-\f
;;; {Load regexp code if regexp primitives are available.}
(if (memq 'regex *features*)
(append! %load-path (cons "." ()))
-\f
-
-(define-module (guile-user))
HCoop / bpt / guile.git / blobdiff