;;; 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
(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)
- (apply read-delimited scm-line-incrementors 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)))))
\f
;;; {Arrays}
;;
;; 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
\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 ((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->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-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}
-;;; !!!! these should be implemented using Tcl commands, not fports.
;;;
+;;; 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.
(define (feature? feature)
(and (memq feature *features*) #t))
;;; {Transcendental Functions}
;;;
;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
-;;; Copyright (C) 1992, 1993 Jerry D. Hedden.
+;;; Written by Jerry D. Hedden, (C) FSF.
;;; See the file `COPYING' for terms applying to this program.
;;;
(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)
(for-each (lambda (char template)
(read-hash-extend char
(make-array-proc template)))
- '(#\b #\a #\u #\e #\s #\i #\c)
- '(#t #\a 1 -1 1.0 1/3 0+i)))
+ '(#\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))
;; pushed to the beginning of the alist since it's used more than the
;; others at present.
-(read-hash-extend #\/ read-path-list-notation)
+(read-hash-extend #\/ read-path-list-notation-warning)
(define (read:array digit port)
(define chr0 (char->integer #\0))
(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 basic-load load)
-(define (load-module . args)
- (save-module-excursion (lambda () (apply basic-load args))))
+(define (load-module filename)
+ (save-module-excursion
+ (lambda ()
+ (let ((oldname (and (current-load-port)
+ (port-filename (current-load-port)))))
+ (basic-load (if (and oldname
+ (> (string-length filename) 0)
+ (not (char=? (string-ref filename 0) #\/))
+ (not (string=? (dirname oldname) ".")))
+ (string-append (dirname oldname) "/" filename)
+ filename))))))
\f
;; (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))
(define %autoloader-developer-mode #t)
+(define (internal-use-syntax transformer)
+ (set-module-transformer! (current-module) transformer)
+ (set! scm:eval-transformer transformer))
+
(define (process-define-module args)
(let* ((module-id (car args))
(module (resolve-module module-id #f))
(for-each (lambda (interface)
(module-use! module interface))
reversed-interfaces)
- (case (cond ((keyword? (car kws))
- (keyword->symbol (car kws)))
- ((and (symbol? (car kws))
- (eq? (string-ref (car kws) 0) #\:))
- (string->symbol (substring (car kws) 1)))
- (else #f))
- ((use-module)
- (if (not (pair? (cdr kws)))
- (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))
- (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))
- (loop (cddr kws) (cons interface reversed-interfaces)))))
- (else
- (error "unrecognized defmodule argument" kws)))))
+ (let ((keyword (cond ((keyword? (car kws))
+ (keyword->symbol (car kws)))
+ ((and (symbol? (car kws))
+ (eq? (string-ref (car kws) 0) #\:))
+ (string->symbol (substring (car kws) 1)))
+ (else #f))))
+ (case keyword
+ ((use-module use-syntax)
+ (if (not (pair? (cdr kws)))
+ (error "unrecognized defmodule argument" kws))
+ (let* ((used-name (cadr kws))
+ (used-module (resolve-module used-name)))
+ (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 (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))
\f
;;; {Autoloading modules}
(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))
#\_))
(string->list mod-name)))
'_module))
- (let ((libname
+
+ ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
+ ;; and the `libname' (the name of the module prepended by `lib') in the cdr
+ ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then
+ ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
+ (let ((subdir-and-libname
(let loop ((dirs "")
(syms module-name))
- (cond
- ((null? (cdr syms))
- (string-append dirs "lib" (car syms) ".so"))
- (else
- (loop (string-append dirs (car syms) "/") (cdr syms))))))
+ (if (null? (cdr syms))
+ (cons dirs (string-append "lib" (car syms)))
+ (loop (string-append dirs (car syms) "/") (cdr syms)))))
(init (make-init-name (apply string-append
(map (lambda (s)
(string-append "_" s))
module-name)))))
- ;; (pk 'libname libname 'init init)
- (or-map
- (lambda (dir)
- (let ((full (in-vicinity dir libname)))
- ;; (pk 'trying full)
- (if (file-exists? full)
- (begin
- (link-dynamic-module full init)
- #t)
- #f)))
- %load-path)))
+ (let ((subdir (car subdir-and-libname))
+ (libname (cdr subdir-and-libname)))
+
+ ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that
+ ;; file exists, fetch the dlname from that file and attempt to link
+ ;; against it. If `subdir/libfoo.la' does not exist, or does not seem
+ ;; to name any shared library, look for `subdir/libfoo.so' instead and
+ ;; link against that.
+ (let check-dirs ((dir-list %load-path))
+ (if (null? dir-list)
+ #f
+ (let* ((dir (in-vicinity (car dir-list) subdir))
+ (sharlib-full
+ (or (try-using-libtool-name dir libname)
+ (try-using-sharlib-name dir libname))))
+ (if (and sharlib-full (file-exists? sharlib-full))
+ (link-dynamic-module sharlib-full init)
+ (check-dirs (cdr dir-list)))))))))
+
+(define (try-using-libtool-name libdir libname)
+ (let ((libtool-filename (in-vicinity libdir
+ (string-append libname ".la"))))
+ (and (file-exists? libtool-filename)
+ (with-input-from-file libtool-filename
+ (lambda ()
+ (let loop ((ln (read-line)))
+ (cond ((eof-object? ln) #f)
+ ((and (> (string-length ln) 9)
+ (string=? "dlname='" (substring ln 0 8))
+ (string-index ln #\' 8))
+ =>
+ (lambda (end)
+ (in-vicinity libdir (substring ln 8 end))))
+ (else (loop (read-line))))))))))
+
+(define (try-using-sharlib-name libdir libname)
+ (in-vicinity libdir (string-append libname ".so")))
(define (link-dynamic-module filename initname)
+ ;; Register any linked modules which 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))
;;; {Run-time options}
-((let* ((names '((debug-options-interface
+((let* ((names '((eval-options-interface
+ (eval-options eval-enable eval-disable)
+ (eval-set!))
+
+ (debug-options-interface
(debug-options debug-enable debug-disable)
(debug-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)
(make-options (lambda (interface)
`(lambda args
(cond ((null? args) (,interface))
- ((pair? (car args))
+ ((list? (car args))
(,interface (car args)) (,interface))
(else (for-each ,print-option
(,interface #t)))))))
(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)
(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 '())
+(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))
+ (let ((status #f)
+ (interactive #t))
+ (set! set-batch-mode?! (lambda (arg)
+ (cond (arg
+ (set! interactive #f)
+ (restore-signals))
+ (#t
+ (error "sorry, not implemented")))))
+ (set! batch-mode? (lambda () (not interactive)))
(define (loop first)
(let ((next
(catch #t
(dynamic-wind
(lambda () (unmask-signals))
(lambda ()
- (first)
+ (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)
+ ;; 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))
;; (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))
(newline (current-error-port))
- (if (and (not has-shown-debugger-hint?)
- (not (memq 'backtrace
- (debug-options-interface)))
- (stack? 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)))
+ (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
(if next (loop next) status)))
(loop (lambda () #t))))
-;;(define the-last-stack #f) Defined by scm_init_backtrace ()
+;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
(define stack-saved? #f)
(define (save-stack . narrowing)
(cond (stack-saved?)
((not (memq 'debug (debug-options-interface)))
- (set! the-last-stack #f)
+ (fluid-set! the-last-stack #f)
(set! stack-saved? #t))
(else
- (set! the-last-stack
- (case (stack-id #t)
- ((repl-stack)
- (apply make-stack #t save-stack eval narrowing))
- ((load-stack)
- (apply make-stack #t save-stack 0 narrowing))
- ((tk-stack)
- (apply make-stack #t save-stack tk-stack-mark 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 narrowing))))))
+ (fluid-set!
+ the-last-stack
+ (case (stack-id #t)
+ ((repl-stack)
+ (apply make-stack #t save-stack eval narrowing))
+ ((load-stack)
+ (apply make-stack #t save-stack 0 narrowing))
+ ((tk-stack)
+ (apply make-stack #t save-stack tk-stack-mark 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 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)
(define (handle-system-error key . args)
(let ((cep (current-error-port)))
- (cond ((not (stack? the-last-stack)))
+ (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 the-last-stack cep)
+ (display-backtrace (fluid-ref the-last-stack) cep)
(newline cep)
- (run-hooks after-backtrace-hook)))
- (run-hooks before-error-hook)
- (apply display-error the-last-stack cep args)
- (run-hooks after-error-hook)
+ (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)))
;; Replaced by C code:
;;(define (backtrace)
-;; (if the-last-stack
+;; (if (fluid-ref the-last-stack)
;; (begin
;; (newline)
-;; (display-backtrace the-last-stack (current-output-port))
+;; (display-backtrace (fluid-ref the-last-stack) (current-output-port))
;; (newline)
;; (if (and (not has-shown-backtrace-hint?)
;; (not (memq 'backtrace (debug-options-interface))))
(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.
+(define repl-reader
+ (lambda (prompt)
+ (display prompt)
+ (force-output)
+ (run-hook before-read-hook)
+ (read (current-input-port))))
(define (scm-style-repl)
(letrec (
(start-gc-rt #f)
(start-rt #f)
- (repl-report-reset (lambda () #f))
(repl-report-start-timing (lambda ()
(set! start-gc-rt (gc-run-time))
(set! start-rt (get-internal-run-time))))
((char=? ch #\newline)
(read-char))))))
(-read (lambda ()
- (if scm-repl-prompt
- (begin
- (display (cond ((string? scm-repl-prompt)
- scm-repl-prompt)
- ((thunk? scm-repl-prompt)
- (scm-repl-prompt))
- (else "> ")))
- (force-output)
- (repl-report-reset)))
- (run-hooks before-read-hook)
- (let ((val (read (current-input-port))))
+ (let ((val
+ (let ((prompt (cond ((string? scm-repl-prompt)
+ scm-repl-prompt)
+ ((thunk? scm-repl-prompt)
+ (scm-repl-prompt))
+ (scm-repl-prompt "> ")
+ (else ""))))
+ (repl-reader prompt))))
+
;; As described in R4RS, the READ procedure updates the
;; port to point to the first characetr past the end of
;; the external representation of the object. This
;; 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}
(defmacro use-modules modules
`(process-use-modules ',modules))
-(define (use-syntax transformer)
- (set-module-transformer! (current-module) transformer)
- (set! scm:eval-transformer transformer))
+(defmacro use-syntax (spec)
+ (if (pair? spec)
+ `(begin
+ (process-use-modules ',(list spec))
+ (internal-use-syntax ,(car (last-pair spec))))
+ `(internal-use-syntax ,spec)))
(define define-private define)
(defmacro ,@ args))))))
+(defmacro export names
+ `(let* ((m (current-module))
+ (public-i (module-public-interface m)))
+ (for-each (lambda (name)
+ ;; Make sure there is a local variable:
+ (module-define! m name (module-ref m name #f))
+ ;; Make sure that local is exported:
+ (module-add! public-i name (module-variable m name)))
+ ',names)))
+
+(define export-syntax export)
+
+
(define load load-module)
-;(define (load . args)
-; (start-stack 'load-stack (apply load-module args)))
\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")
;; the protected thunk.
(lambda ()
- (scm-style-repl))
+
+ ;; If we've got readline, use it to prompt the user. This is a
+ ;; kludge, but we'll fix it soon. At least we only get
+ ;; readline involved when we're actually running the repl.
+ (if (and (memq 'readline *features*)
+ (isatty? (current-input-port))
+ (not (and (module-defined? the-root-module
+ 'use-emacs-interface)
+ use-emacs-interface)))
+ (let ((read-hook (lambda () (run-hook before-read-hook))))
+ (set-current-input-port (readline-port))
+ (set! repl-reader
+ (lambda (prompt)
+ (dynamic-wind
+ (lambda ()
+ (set-readline-prompt! prompt)
+ (set-readline-read-hook! read-hook))
+ (lambda () (read))
+ (lambda ()
+ (set-readline-prompt! "")
+ (set-readline-read-hook! #f)))))))
+ (let ((status (scm-style-repl)))
+ (run-hook exit-hook)
+ status))
;; call at exit.
(lambda ()
`(catch #t (lambda () ,expr)
(lambda args #f)))
-;;; {Load debug extension code if debug extensions present.}
-;;;
-;;; *fixme* This is a temporary solution.
+;;; This hook is run at the very end of an interactive session.
;;;
+(define exit-hook (make-hook))
-(if (memq 'debug-extensions *features*)
- (define-module (guile) :use-module (ice-9 debug)))
+;;; Load readline code into root module if readline primitives are available.
+;;;
+;;; Ideally, we wouldn't do this until we were sure we were actually
+;;; going to enter the repl, but autoloading individual functions is
+;;; clumsy at the moment.
+(if (and (memq 'readline *features*)
+ (isatty? (current-input-port)))
+ (begin
+ (define-module (guile) :use-module (ice-9 readline))
+ (define-module (guile-user) :use-module (ice-9 readline))))
\f
-;;; {Load session support if present.}
+;;; {Load debug extension code into user module if debug extensions present.}
;;;
;;; *fixme* This is a temporary solution.
;;;
-(if (%search-load-path "ice-9/session.scm")
- (define-module (guile) :use-module (ice-9 session)))
+(if (memq 'debug-extensions *features*)
+ (define-module (guile-user) :use-module (ice-9 debug)))
\f
-;;; {Load thread code if threads are present.}
+;;; {Load session support into user module if present.}
;;;
;;; *fixme* This is a temporary solution.
;;;
-(if (memq 'threads *features*)
- (define-module (guile) :use-module (ice-9 threads)))
+(if (%search-load-path "ice-9/session.scm")
+ (define-module (guile-user) :use-module (ice-9 session)))
-\f
-;;; {Load emacs interface support if emacs option is given.}
+;;; {Load thread code into user module if threads are present.}
;;;
;;; *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) :use-module (ice-9 emacs))))
+(if (memq 'threads *features*)
+ (define-module (guile-user) :use-module (ice-9 threads)))
\f
;;; {Load regexp code if regexp primitives are available.}
(if (memq 'regex *features*)
- (define-module (guile) :use-module (ice-9 regex)))
+ (define-module (guile-user) :use-module (ice-9 regex)))
\f
+(define-module (guile))
+
;;; {Check that the interpreter and scheme code match up.}
(let ((show-line
(show-line "libguile: configured on " (libguile-config-stamp))
(show-line "ice-9: configured on " (ice-9-config-stamp)))))
-\f
-
-(define-module (guile))
-
(append! %load-path (cons "." ()))
-(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))
HCoop / bpt / guile.git / blobdiff