;;; installed-scm-file
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
\f
(char_pred (string-ref s (1- end))))
(string-every-c-code char_pred s start end))))
+;; A variant of string-fill! that we keep for compatability
+;;
+(define (substring-fill! str start end fill)
+ (string-fill! str fill start end))
+
\f
;;; {EVAL-CASE}
(define (record-predicate rtd)
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
+(define (%record-type-check rtd obj) ;; private helper
+ (or (eq? rtd (record-type-descriptor obj))
+ (scm-error 'wrong-type-arg "%record-type-check"
+ "Wrong type record (want `~S'): ~S"
+ (list (record-type-name rtd) obj)
+ #f)))
+
(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))
(local-eval `(lambda (obj)
- (and (eq? ',rtd (record-type-descriptor obj))
- (struct-ref obj ,pos)))
+ (%record-type-check ',rtd obj)
+ (struct-ref obj ,pos))
the-root-environment)))
(define (record-modifier rtd field-name)
(if (not pos)
(error 'no-such-field field-name))
(local-eval `(lambda (obj val)
- (and (eq? ',rtd (record-type-descriptor obj))
- (struct-set! obj ,pos val)))
+ (%record-type-check ',rtd obj)
+ (struct-set! obj ,pos val))
the-root-environment)))
;;; 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)
(/ (log (/ (- +i z) (+ +i z))) +2i))
($atan2 z (car y))))
-(define (log10 arg)
- (/ (log arg) (log 10)))
-
\f
;;; {Reader Extensions}
(define basic-load load)
-(define (load-module filename)
+(define (load-module filename . reader)
(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))))))
+ (apply 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)
+ reader)))))
\f
(exports '())
(re-exports '())
(replacements '()))
+
(if (null? kws)
(call-with-deferred-observers
(lambda ()
(let ((i (module-public-interface (resolve-module name))))
(if (not i)
(error "missing interface for module" name))
- ;; Replace autoload-interface with interface
- (set-car! (memq a (module-uses module)) i)
+ (let ((autoload (memq a (module-uses module))))
+ ;; Replace autoload-interface with actual interface if
+ ;; that has not happened yet.
+ (if (pair? autoload)
+ (set-car! autoload i)))
(module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f
'() (make-weak-value-hash-table 31) 0)))
(load-file load-compiled full)))
((%search-load-path file)
=> (lambda (full)
- (load-file primitive-load full))))))
+ (with-fluids ((current-reader #f))
+ (load-file primitive-load full)))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
(catch #t
(lambda ()
- (lazy-catch #t
- (lambda ()
- (call-with-unblocked-asyncs
- (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)))))
-
- ;; Note that having just
- ;; `lazy-handler-dispatch' here is
- ;; connected with the mechanism that
- ;; produces a nice backtrace upon
- ;; error. If, for example, this is
- ;; replaced with (lambda args (apply
- ;; lazy-handler-dispatch args)), the
- ;; stack cutting (in save-stack)
- ;; goes wrong and ends up saving no
- ;; stack at all, so there is no
- ;; backtrace.
- lazy-handler-dispatch))
+ (call-with-unblocked-asyncs
+ (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 (key . args)
(case key
(cond ((= (length args) 4)
(apply handle-system-error key args))
(else
- (apply bad-throw key args))))))))))
+ (apply bad-throw key args)))))))
+
+ ;; Note that having just `lazy-handler-dispatch'
+ ;; here is connected with the mechanism that
+ ;; produces a nice backtrace upon error. If, for
+ ;; example, this is replaced with (lambda args
+ ;; (apply lazy-handler-dispatch args)), the stack
+ ;; cutting (in save-stack) goes wrong and ends up
+ ;; saving no stack at all, so there is no
+ ;; backtrace.
+ lazy-handler-dispatch)))
+
(if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg)
(cond (arg
(display prompt)
(force-output)
(run-hook before-read-hook)
- (read (current-input-port))))
+ ((or (fluid-ref current-reader) read) (current-input-port))))
(define (scm-style-repl)
;;;
;;; Currently, the following feature identifiers are supported:
;;;
-;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14
+;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
;;;
;;; Remember to update the features list when adding more SRFIs.
;;;
srfi-13 ;; string library
srfi-14 ;; character sets
srfi-55 ;; require-extension
+ srfi-61 ;; general cond clause
))
;; This table maps module public interfaces to the list of features.
;; numbers, which are the numbers of the SRFIs to be loaded on startup.
;;
(define (use-srfis srfis)
- (let lp ((s srfis))
- (if (pair? s)
- (let* ((srfi (string->symbol
- (string-append "srfi-" (number->string (car s)))))
- (mod-i (resolve-interface (list 'srfi srfi))))
- (module-use! (current-module) mod-i)
- (lp (cdr s))))))
+ (process-use-modules
+ (map (lambda (num)
+ (list (list 'srfi (string->symbol
+ (string-append "srfi-" (number->string num))))))
+ srfis)))
\f
;; Use some convenient modules (in reverse order)
- (if (provided? 'regex)
- (module-use! guile-user-module (resolve-interface '(ice-9 regex))))
- (if (provided? 'threads)
- (module-use! guile-user-module (resolve-interface '(ice-9 threads))))
+ (set-current-module guile-user-module)
+ (process-use-modules
+ (append
+ '(((ice-9 r5rs))
+ ((ice-9 session))
+ ((ice-9 debug)))
+ (if (provided? 'regex)
+ '(((ice-9 regex)))
+ '())
+ (if (provided? 'threads)
+ '(((ice-9 threads)))
+ '())))
;; load debugger on demand
(module-use! guile-user-module
(make-autoload-interface guile-user-module
'(ice-9 debugger) '(debug)))
- (module-use! guile-user-module (resolve-interface '(ice-9 session)))
- (module-use! guile-user-module (resolve-interface '(ice-9 debug)))
- ;; so that builtin bindings will be checked first
- (module-use! guile-user-module (resolve-interface '(ice-9 r5rs)))
- (module-use! guile-user-module (resolve-interface '(guile)))
- (set-current-module guile-user-module)
+ ;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
+ ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
+ ;; no effect.
(let ((old-handlers #f)
(signals (if (provided? 'posix)
`((,SIGINT . "User interrupt")
(,SIGFPE . "Arithmetic error")
- (,SIGBUS . "Bad memory access (bus error)")
(,SIGSEGV
. "Bad memory access (Segmentation violation)"))
'())))
+ ;; no SIGBUS on mingw
+ (if (defined? 'SIGBUS)
+ (set! signals (acons SIGBUS "Bad memory access (bus error)"
+ signals)))
(dynamic-wind
HCoop / bpt / guile.git / blobdiff