(define (provided? feature)
(and (memq feature *features*) #t))
+;;; presumably deprecated.
+(define feature? provided?)
+
+;;; let format alias simple-format until the more complete version is loaded
+(define format simple-format)
+
\f
;;; {R4RS compliance}
;;; {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))))
+(if (provided? 'array)
+ (primitive-load-path "ice-9/arrays.scm"))
\f
;;; {Keywords}
;; 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))
+ (if (get-print-state old-port)
+ (port-with-print-state new-port (get-print-state old-port))
new-port))
;; 0: type-name, 1: fields
(loop (f (car l)) (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)
- (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 add-hook!
- (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
- (or *suppress-old-style-hook-warning*
- (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 ((hook (local-eval (cadr exp) env)))
- (if (and (pair? hook) (eq? (car hook) 'hook))
- `(new-remove-hook! ,@(cdr exp))
- (begin
- (or *suppress-old-style-hook-warning*
- (display "Warning: Old style hooks\n" (current-error-port)))
- `(let ((thunk ,(caddr exp)))
- (set! ,(cadr exp)
- (delq! thunk ,(cadr exp))))))))))
-
-\f
-;;; {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.
-(define (feature? feature)
- (and (memq feature *features*) #t))
+(if (provided? 'posix)
+ (primitive-load-path "ice-9/posix.scm"))
-;; 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 (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))
+(if (provided? 'socket)
+ (primitive-load-path "ice-9/networking.scm"))
(define file-exists?
- (if (feature? 'posix)
+ (if (provided? 'posix)
(lambda (str)
(access? str F_OK))
(lambda (str)
#f)))))
(define file-is-directory?
- (if (feature? 'i/o-extensions)
+ (if (provided? 'posix)
(lambda (str)
(eq? (stat:type (stat str)) 'directory))
(lambda (str)
- (display str)
- (newline)
(let ((port (catch 'system-error
(lambda () (open-file (string-append str "/.")
OPEN_READ))
(save-stack)
(if (null? args)
(scm-error 'misc-error #f "?" #f #f)
- (let loop ((msg "%s")
+ (let loop ((msg "~A")
(rest (cdr args)))
(if (not (null? rest))
- (loop (string-append msg " %S")
+ (loop (string-append msg " ~S")
(cdr rest))
(scm-error 'misc-error #f msg args #f)))))
(apply error "unhandled-exception:" key args))))
\f
-;;; {Non-polymorphic versions of POSIX functions}
-
-(define (getgrnam name) (getgr name))
-(define (getgrgid id) (getgr id))
-(define (gethostbyaddr addr) (gethost addr))
-(define (gethostbyname name) (gethost name))
-(define (getnetbyaddr addr) (getnet addr))
-(define (getnetbyname name) (getnet name))
-(define (getprotobyname name) (getproto name))
-(define (getprotobynumber addr) (getproto addr))
-(define (getpwnam name) (getpw name))
-(define (getpwuid uid) (getpw uid))
-(define (getservbyname name proto) (getserv name proto))
-(define (getservbyport port proto) (getserv port proto))
-(define (endgrent) (setgr))
-(define (endhostent) (sethost))
-(define (endnetent) (setnet))
-(define (endprotoent) (setproto))
-(define (endpwent) (setpw))
-(define (endservent) (setserv))
-(define (getgrent) (getgr))
-(define (gethostent) (gethost))
-(define (getnetent) (getnet))
-(define (getprotoent) (getproto))
-(define (getpwent) (getpw))
-(define (getservent) (getserv))
-(define (setgrent) (setgr #f))
-(define (sethostent) (sethost #t))
-(define (setnetent) (setnet #t))
-(define (setprotoent) (setproto #t))
-(define (setpwent) (setpw #t))
-(define (setservent) (setserv #t))
-
-(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 (hostent:name obj) (vector-ref obj 0))
-(define (hostent:aliases obj) (vector-ref obj 1))
-(define (hostent:addrtype obj) (vector-ref obj 2))
-(define (hostent:length obj) (vector-ref obj 3))
-(define (hostent:addr-list obj) (vector-ref obj 4))
-
-(define (netent:name obj) (vector-ref obj 0))
-(define (netent:aliases obj) (vector-ref obj 1))
-(define (netent:addrtype obj) (vector-ref obj 2))
-(define (netent:net obj) (vector-ref obj 3))
-
-(define (protoent:name obj) (vector-ref obj 0))
-(define (protoent:aliases obj) (vector-ref obj 1))
-(define (protoent:proto obj) (vector-ref obj 2))
-
-(define (servent:name obj) (vector-ref obj 0))
-(define (servent:aliases obj) (vector-ref obj 1))
-(define (servent:port obj) (vector-ref obj 2))
-(define (servent:proto obj) (vector-ref obj 3))
-
-(define (sockaddr:fam obj) (vector-ref obj 0))
-(define (sockaddr:path obj) (vector-ref obj 1))
-(define (sockaddr:addr obj) (vector-ref obj 1))
-(define (sockaddr:port obj) (vector-ref obj 2))
-
-(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 (tm:sec obj) (vector-ref obj 0))
(define (tm:min obj) (vector-ref obj 1))
;; This is mostly for the internal use of the code generated by
;; scm_compile_shell_switches.
(define (load-user-init)
- (define (has-init? dir)
+ (define (existing-file 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 (and (file-exists? path)
+ (not (file-is-directory? path)))
+ path
+ #f)))
+ (let ((path (or (existing-file (or (getenv "HOME") "/"))
+ (and (provided? 'posix)
+ (existing-file (passwd:dir (getpw (getuid))))))))
(if path (primitive-load path))))
\f
;;; 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))))
-(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")))
-
\f
;;; {Command Line Options}
;;;
;;
(define module-type
(make-record-type 'module
- '(obarray uses binder eval-closure transformer name kind)
+ '(obarray uses binder eval-closure transformer name kind
+ observers weak-observers observer-id)
%print-module))
;; make-module &opt size uses binder
"Lazy-binder expected to be a procedure or #f." binder))
(let ((module (module-constructor (make-vector size '())
- uses binder #f #f #f #f)))
+ uses binder #f #f #f #f
+ '()
+ (make-weak-value-hash-table 31)
+ 0)))
;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define set-module-kind! (record-modifier module-type 'kind))
+(define module-observers (record-accessor module-type 'observers))
+(define set-module-observers! (record-modifier module-type 'observers))
+(define module-weak-observers (record-accessor module-type 'weak-observers))
+(define module-observer-id (record-accessor module-type 'observer-id))
+(define set-module-observer-id! (record-modifier module-type 'observer-id))
(define module? (record-predicate module-type))
(define set-module-eval-closure!
(eval2 exp (module-eval-closure module)))
\f
+;;; {Observer protocol}
+;;;
+
+(define (module-observe module proc)
+ (set-module-observers! module (cons proc (module-observers module)))
+ (cons module proc))
+
+(define (module-observe-weak module proc)
+ (let ((id (module-observer-id module)))
+ (hash-set! (module-weak-observers module) id proc)
+ (set-module-observer-id! module (+ 1 id))
+ (cons module id)))
+
+(define (module-unobserve token)
+ (let ((module (car token))
+ (id (cdr token)))
+ (if (integer? id)
+ (hash-remove! (module-weak-observers module) id)
+ (set-module-observers! module (delq1! id (module-observers module)))))
+ *unspecified*)
+
+(define (module-modified m)
+ (for-each (lambda (proc) (proc m)) (module-observers m))
+ (hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
+
+\f
;;; {Module Searching in General}
;;;
;;; We sometimes want to look for properties of a symbol
;;
(define (module-make-local-var! m v)
(or (let ((b (module-obarray-ref (module-obarray m) v)))
- (and (variable? b) b))
+ (and (variable? b)
+ (begin
+ (module-modified m)
+ b)))
(and (module-binder m)
((module-binder m) m v #t))
(begin
(let ((answer (make-undefined-variable v)))
(module-obarray-set! (module-obarray m) v answer)
+ (module-modified m)
answer))))
;; module-add! module symbol var
(define (module-add! m v var)
(if (not (variable? var))
(error "Bad variable to module-add!" var))
- (module-obarray-set! (module-obarray m) v var))
+ (module-obarray-set! (module-obarray m) v var)
+ (module-modified m))
;; module-remove!
;;
;; make sure that a symbol is undefined in the local namespace of M.
;;
(define (module-remove! m v)
- (module-obarray-remove! (module-obarray m) v))
+ (module-obarray-remove! (module-obarray m) v)
+ (module-modified m))
(define (module-clear! m)
- (vector-fill! (module-obarray m) '()))
+ (vector-fill! (module-obarray m) '())
+ (module-modified m))
;; MODULE-FOR-EACH -- exported
;;
(define (module-define! module name value)
(let ((variable (module-local-variable module name)))
(if variable
- (variable-set! variable value)
+ (begin
+ (variable-set! variable value)
+ (module-modified module))
(module-add! module name (make-variable value name)))))
;; MODULE-DEFINED? -- exported
;;
(define (module-use! module interface)
(set-module-uses! module
- (cons interface (delq! interface (module-uses module)))))
+ (cons interface (delq! interface (module-uses module))))
+ (module-modified module))
\f
;;; {Recursive Namespaces}
;; Replace autoload-interface with interface
(set-car! (memq a (module-uses module)) i)
(module-local-variable i sym))))))
- (module-constructor #() #f b #f #f name 'autoload)))
+ (module-constructor #() #f b #f #f name 'autoload
+ '() (make-weak-value-hash-table 31) 0)))
\f
;;; {Autoloading modules}
(let ((didit #f))
(dynamic-wind
(lambda () (autoload-in-progress! dir-hint name))
- (lambda ()
- (let loop ((dirs %load-path))
- (and (not (null? dirs))
- (or
- (let ((d (car dirs))
- (trys (list
- dir-hint
- (sfx dir-hint)
- (in-vicinity dir-hint name)
- (in-vicinity dir-hint (sfx name)))))
- (and (or-map (lambda (f)
- (let ((full (in-vicinity d f)))
- full
- (and (file-exists? full)
- (not (file-is-directory? full))
- (begin
- (save-module-excursion
- (lambda ()
- (load (string-append
- d "/" f))))
- #t))))
- trys)
- (begin
- (set! didit #t)
- #t)))
- (loop (cdr dirs))))))
+ (lambda ()
+ (let ((full (%search-load-path (in-vicinity dir-hint name))))
+ (if full
+ (begin
+ (save-module-excursion (lambda () (primitive-load full)))
+ (set! didit #t)))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
(define (find-and-link-dynamic-module module-name)
(define (make-init-name mod-name)
- (string-append 'scm_init
+ (string-append "scm_init"
(list->string (map (lambda (c)
(if (or (char-alphabetic? c)
(char-numeric? c))
c
#\_))
(string->list mod-name)))
- '_module))
+ "_module"))
;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
;; and the `libname' (the name of the module prepended by `lib') in the cdr
(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))))))))))
+ libtool-filename)))
(define (try-using-sharlib-name libdir libname)
(in-vicinity libdir (string-append libname ".so")))
(define (error-catching-loop thunk)
(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
(else
(apply bad-throw key args))))))))))
(if next (loop next) status)))
+ (set! set-batch-mode?! (lambda (arg)
+ (cond (arg
+ (set! interactive #f)
+ (restore-signals))
+ (#t
+ (error "sorry, not implemented")))))
+ (set! batch-mode? (lambda () (not interactive)))
(loop (lambda () #t))))
;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
+(define before-signal-stack (make-fluid))
(define stack-saved? #f)
(define (save-stack . narrowing)
((memq 'backtrace (debug-options-interface))
(run-hook before-backtrace-hook)
(newline cep)
+ (display "Backtrace:\n")
(display-backtrace (fluid-ref the-last-stack) cep)
(newline cep)
(run-hook after-backtrace-hook)))
(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))
-;; (define out-ch (get-standard-channel TCL_STDOUT))
-;; (define err-ch (get-standard-channel TCL_STDERR))
-;;
-;; (define inp (%make-channel-port in-ch "r"))
-;; (define outp (%make-channel-port out-ch "w"))
-;; (define errp (%make-channel-port err-ch "w"))
-;;
-;; (define %system-char-ready? char-ready?)
-;;
-;; (define (char-ready? p)
-;; (if (not (channel-port? p))
-;; (%system-char-ready? p)
-;; (let* ((channel (%channel-port-channel p))
-;; (old-blocking (channel-option-ref channel :blocking)))
-;; (dynamic-wind
-;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking "0"))
-;; (lambda () (not (eof-object? (peek-char p))))
-;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking old-blocking))))))
-;;
-;; (define (top-repl)
-;; (with-input-from-port inp
-;; (lambda ()
-;; (with-output-to-port outp
-;; (lambda ()
-;; (with-error-to-port errp
-;; (lambda ()
-;; (scm-style-repl))))))))
-;;
-;; (set-current-input-port inp)
-;; (set-current-output-port outp)
-;; (set-current-error-port errp)
+(define using-readline?
+ (let ((using-readline? (make-fluid)))
+ (make-procedure-with-setter
+ (lambda () (fluid-ref using-readline?))
+ (lambda (v) (fluid-set! using-readline? v)))))
;; this is just (scm-style-repl) with a wrapper to install and remove
;; signal handlers.
(load-emacs-interface))
;; Place the user in the guile-user module.
- (define-module (guile-user))
+ (define-module (guile-user)
+ :use-module (guile) ;so that bindings will be checked here first
+ :use-module (ice-9 session)
+ :use-module (ice-9 debug)
+ :autoload (ice-9 debugger) (debug)) ;load debugger on demand
+ (if (memq 'threads *features*)
+ (define-module (guile-user) :use-module (ice-9 threads)))
+ (if (memq 'regex *features*)
+ (define-module (guile-user) :use-module (ice-9 regex)))
(let ((old-handlers #f)
- (signals `((,SIGINT . "User interrupt")
- (,SIGFPE . "Arithmetic error")
- (,SIGBUS . "Bad memory access (bus error)")
- (,SIGSEGV . "Bad memory access (Segmentation violation)"))))
+ (signals (if (provided? 'posix)
+ `((,SIGINT . "User interrupt")
+ (,SIGFPE . "Arithmetic error")
+ (,SIGBUS . "Bad memory access (bus error)")
+ (,SIGSEGV .
+ "Bad memory access (Segmentation violation)"))
+ '())))
(dynamic-wind
(lambda ()
(let ((make-handler (lambda (msg)
(lambda (sig)
+ ;; Make a backup copy of the stack
+ (fluid-set! before-signal-stack
+ (fluid-ref the-last-stack))
(save-stack %deliver-signals)
(scm-error 'signal
#f
;; the protected thunk.
(lambda ()
-
- ;; 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))
(sigaction (car sig-msg)
(car old-handler)
(cdr old-handler))))
- signals old-handlers)))))
+ signals old-handlers)))))
(defmacro false-if-exception (expr)
`(catch #t (lambda () ,expr)
;;;
(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
-;;; 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 debug extension code into user module if debug extensions present.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (memq 'debug-extensions *features*)
- (define-module (guile-user) :use-module (ice-9 debug)))
-
-\f
-;;; {Load session support into user module if present.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (%search-load-path "ice-9/session.scm")
- (define-module (guile-user) :use-module (ice-9 session)))
-
-;;; {Load thread code into user module if threads are present.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(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-user) :use-module (ice-9 regex)))
-
\f
(define-module (guile))
-;;; {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)))))
-
(append! %load-path (cons "." ()))
-
HCoop / bpt / guile.git / blobdiff