\f
-;;; {and-map, or-map, and map-in-order}
+;;; {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))
(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)
`(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
(lambda () ,@body)))
+;;; Environments
+
+(define the-environment
+ (procedure->syntax
+ (lambda (x e)
+ e)))
+
\f
;;; {Macros}
(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)
(set-readline-prompt! "")
(set-readline-read-hook! #f)))))))
(let ((status (scm-style-repl)))
- (run-hooks exit-hook)
+ (run-hook exit-hook)
status))
;; call at exit.
;;; This hook is run at the very end of an interactive session.
;;;
-(define exit-hook '())
+(define exit-hook (make-hook))
;;; Load readline code into root module if readline primitives are available.
;;;
HCoop / bpt / guile.git / blobdiff