;;; installed-scm-file
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006
;;;; 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 (identity x) x)
-(define (1+ n) (+ n 1))
-(define (1- n) (+ n -1))
(define (and=> value procedure) (and value (procedure value)))
(define call/cc call-with-current-continuation)
(define (environment-module env)
(let ((closure (and (pair? env) (car (last-pair env)))))
- (and closure (procedure-property closure 'module))))
+ (and closure (eval-closure-module closure))))
\f
n
(loop (+ n 1) (cdr l))))))
-(define (make-list n . init)
- (if (pair? init) (set! init (car init)))
- (let loop ((answer '())
- (n n))
- (if (<= n 0)
- answer
- (loop (cons init answer) (- n 1)))))
-
\f
;;; {and-map and or-map}
(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)
;; `while' even when recursing. `while-helper' is an easy way to keep the
;; `key' binding away from the cond and body code.
;;
+;; FIXME: This is supposed to have an `unquote' on the `do' the same used
+;; for lambda and not, so as to protect against any user rebinding of that
+;; symbol, but unfortunately an unquote breaks with ice-9 syncase, eg.
+;;
+;; (use-modules (ice-9 syncase))
+;; (while #f)
+;; => ERROR: invalid syntax ()
+;;
+;; This is probably a bug in syncase.
+;;
(define-macro (while cond . body)
(define (while-helper proc)
(do ((key (make-symbol "while-key")))
(lambda () (throw key #f))))
(lambda (key arg) arg)))))
`(,while-helper (,lambda (break continue)
- (,do ()
+ (do ()
((,not ,cond))
,@body)
#t)))
;;;
;;; 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-6 ;; open-input-string etc, in the guile core
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.
\f
+;;; srfi-55: require-extension
+;;;
+
+(define-macro (require-extension extension-spec)
+ ;; This macro only handles the srfi extension, which, at present, is
+ ;; the only one defined by the standard.
+ (if (not (pair? extension-spec))
+ (scm-error 'wrong-type-arg "require-extension"
+ "Not an extension: ~S" (list extension-spec) #f))
+ (let ((extension (car extension-spec))
+ (extension-args (cdr extension-spec)))
+ (case extension
+ ((srfi)
+ (let ((use-list '()))
+ (for-each
+ (lambda (i)
+ (if (not (integer? i))
+ (scm-error 'wrong-type-arg "require-extension"
+ "Invalid srfi name: ~S" (list i) #f))
+ (let ((srfi-sym (string->symbol
+ (string-append "srfi-" (number->string i)))))
+ (if (not (memq srfi-sym %cond-expand-features))
+ (set! use-list (cons `(use-modules (srfi ,srfi-sym))
+ use-list)))))
+ extension-args)
+ (if (pair? use-list)
+ ;; i.e. (begin (use-modules x) (use-modules y) (use-modules z))
+ `(begin ,@(reverse! use-list)))))
+ (else
+ (scm-error
+ 'wrong-type-arg "require-extension"
+ "Not a recognized extension type: ~S" (list extension) #f)))))
+
+\f
+
;;; {Load emacs interface support if emacs option is given.}
;;;
HCoop / bpt / guile.git / blobdiff