;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(define with-throw-handler #f)
(let ()
- ;; Ideally we'd like to be able to give these default values for all threads,
- ;; even threads not created by Guile; but alack, that does not currently seem
- ;; possible. So wrap the getters in thunks.
- (define %running-exception-handlers (make-fluid))
- (define %exception-handler (make-fluid))
-
- (define (running-exception-handlers)
- (or (fluid-ref %running-exception-handlers)
- (begin
- (fluid-set! %running-exception-handlers '())
- '())))
- (define (exception-handler)
- (or (fluid-ref %exception-handler)
- (begin
- (fluid-set! %exception-handler default-exception-handler)
- default-exception-handler)))
-
(define (default-exception-handler k . args)
(cond
((eq? k 'quit)
(format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
(primitive-exit 1))))
+ (define %running-exception-handlers (make-fluid '()))
+ (define %exception-handler (make-fluid default-exception-handler))
+
(define (default-throw-handler prompt-tag catch-k)
- (let ((prev (exception-handler)))
+ (let ((prev (fluid-ref %exception-handler)))
(lambda (thrown-k . args)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
(apply abort-to-prompt prompt-tag thrown-k args)
(apply prev thrown-k args)))))
(define (custom-throw-handler prompt-tag catch-k pre)
- (let ((prev (exception-handler)))
+ (let ((prev (fluid-ref %exception-handler)))
(lambda (thrown-k . args)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
- (let ((running (running-exception-handlers)))
+ (let ((running (fluid-ref %running-exception-handlers)))
(with-fluids ((%running-exception-handlers (cons pre running)))
(if (not (memq pre running))
(apply pre thrown-k args))
and then calls the normal (third argument) handler. If it exits
non-locally, that exit determines the continuation."
(if (not (or (symbol? k) (eqv? k #t)))
- (scm-error "catch" 'wrong-type-arg
+ (scm-error 'wrong-type-arg "catch"
"Wrong type argument in position ~a: ~a"
(list 1 k) (list k)))
(let ((tag (make-prompt-tag "catch")))
(set! with-throw-handler
(lambda (k thunk pre-unwind-handler)
"Add @var{handler} to the dynamic context as a throw handler
-for key @var{key}, then invoke @var{thunk}."
+for key @var{k}, then invoke @var{thunk}."
(if (not (or (symbol? k) (eqv? k #t)))
- (scm-error "with-throw-handler" 'wrong-type-arg
+ (scm-error 'wrong-type-arg "with-throw-handler"
"Wrong type argument in position ~a: ~a"
(list 1 k) (list k)))
(with-fluids ((%exception-handler
If there is no handler at all, Guile prints an error and then exits."
(if (not (symbol? key))
- ((exception-handler) 'wrong-type-arg "throw"
+ ((fluid-ref %exception-handler) 'wrong-type-arg "throw"
"Wrong type argument in position ~a: ~a" (list 1 key) (list key))
- (apply (exception-handler) key args)))))
+ (apply (fluid-ref %exception-handler) key args)))))
\f
(define pk peek)
+;; Temporary definition; replaced later.
+(define current-warning-port current-error-port)
(define (warn . stuff)
- (with-output-to-port (current-error-port)
+ (with-output-to-port (current-warning-port)
(lambda ()
(newline)
(display ";;; WARNING ")
\f
+;;; Boot versions of `map' and `for-each', enough to get the expander
+;;; running.
+;;;
+(define map
+ (case-lambda
+ ((f l)
+ (let map1 ((l l))
+ (if (null? l)
+ '()
+ (cons (f (car l)) (map1 (cdr l))))))
+ ((f l1 l2)
+ (let map2 ((l1 l1) (l2 l2))
+ (if (null? l1)
+ '()
+ (cons (f (car l1) (car l2))
+ (map2 (cdr l1) (cdr l2))))))
+ ((f l1 . rest)
+ (let lp ((l1 l1) (rest rest))
+ (if (null? l1)
+ '()
+ (cons (apply f (car l1) (map car rest))
+ (lp (cdr l1) (map cdr rest))))))))
+
+(define for-each
+ (case-lambda
+ ((f l)
+ (let for-each1 ((l l))
+ (if (pair? l)
+ (begin
+ (f (car l))
+ (for-each1 (cdr l))))))
+ ((f l1 l2)
+ (let for-each2 ((l1 l1) (l2 l2))
+ (if (pair? l1)
+ (begin
+ (f (car l1) (car l2))
+ (for-each2 (cdr l1) (cdr l2))))))
+ ((f l1 . rest)
+ (let lp ((l1 l1) (rest rest))
+ (if (pair? l1)
+ (begin
+ (apply f (car l1) (map car rest))
+ (lp (cdr l1) (map cdr rest))))))))
+
;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
((_ x) x)
((_ x y ...) (let ((t x)) (if t t (or y ...))))))
-;; The "maybe-more" bits are something of a hack, so that we can support
-;; SRFI-61. Rewrites into a standalone syntax-case macro would be
-;; appreciated.
-(define-syntax cond
- (syntax-rules (=> else)
- ((_ "maybe-more" test consequent)
- (if test consequent))
-
- ((_ "maybe-more" test consequent clause ...)
- (if test consequent (cond clause ...)))
-
- ((_ (else else1 else2 ...))
- (begin else1 else2 ...))
-
- ((_ (test => receiver) more-clause ...)
- (let ((t test))
- (cond "maybe-more" t (receiver t) more-clause ...)))
-
- ((_ (generator guard => receiver) more-clause ...)
- (call-with-values (lambda () generator)
- (lambda t
- (cond "maybe-more"
- (apply guard t) (apply receiver t) more-clause ...))))
-
- ((_ (test => receiver ...) more-clause ...)
- (syntax-violation 'cond "wrong number of receiver expressions"
- '(test => receiver ...)))
- ((_ (generator guard => receiver ...) more-clause ...)
- (syntax-violation 'cond "wrong number of receiver expressions"
- '(generator guard => receiver ...)))
-
- ((_ (test) more-clause ...)
- (let ((t test))
- (cond "maybe-more" t t more-clause ...)))
+(include-from-path "ice-9/quasisyntax")
+
+(define-syntax-rule (when test stmt stmt* ...)
+ (if test (begin stmt stmt* ...)))
- ((_ (test body1 body2 ...) more-clause ...)
- (cond "maybe-more"
- test (begin body1 body2 ...) more-clause ...))))
+(define-syntax-rule (unless test stmt stmt* ...)
+ (if (not test) (begin stmt stmt* ...)))
+
+(define-syntax cond
+ (lambda (whole-expr)
+ (define (fold f seed xs)
+ (let loop ((xs xs) (seed seed))
+ (if (null? xs) seed
+ (loop (cdr xs) (f (car xs) seed)))))
+ (define (reverse-map f xs)
+ (fold (lambda (x seed) (cons (f x) seed))
+ '() xs))
+ (syntax-case whole-expr ()
+ ((_ clause clauses ...)
+ #`(begin
+ #,@(fold (lambda (clause-builder tail)
+ (clause-builder tail))
+ #'()
+ (reverse-map
+ (lambda (clause)
+ (define* (bad-clause #:optional (msg "invalid clause"))
+ (syntax-violation 'cond msg whole-expr clause))
+ (syntax-case clause (=> else)
+ ((else e e* ...)
+ (lambda (tail)
+ (if (null? tail)
+ #'((begin e e* ...))
+ (bad-clause "else must be the last clause"))))
+ ((else . _) (bad-clause))
+ ((test => receiver)
+ (lambda (tail)
+ #`((let ((t test))
+ (if t
+ (receiver t)
+ #,@tail)))))
+ ((test => receiver ...)
+ (bad-clause "wrong number of receiver expressions"))
+ ((generator guard => receiver)
+ (lambda (tail)
+ #`((call-with-values (lambda () generator)
+ (lambda vals
+ (if (apply guard vals)
+ (apply receiver vals)
+ #,@tail))))))
+ ((generator guard => receiver ...)
+ (bad-clause "wrong number of receiver expressions"))
+ ((test)
+ (lambda (tail)
+ #`((let ((t test))
+ (if t t #,@tail)))))
+ ((test e e* ...)
+ (lambda (tail)
+ #`((if test
+ (begin e e* ...)
+ #,@tail))))
+ (_ (bad-clause))))
+ #'(clause clauses ...))))))))
(define-syntax case
- (syntax-rules (else)
- ((case (key ...)
- clauses ...)
- (let ((atom-key (key ...)))
- (case atom-key clauses ...)))
- ((case key
- (else result1 result2 ...))
- (begin result1 result2 ...))
- ((case key
- ((atoms ...) result1 result2 ...))
- (if (memv key '(atoms ...))
- (begin result1 result2 ...)))
- ((case key
- ((atoms ...) result1 result2 ...)
- clause clauses ...)
- (if (memv key '(atoms ...))
- (begin result1 result2 ...)
- (case key clause clauses ...)))))
+ (lambda (whole-expr)
+ (define (fold f seed xs)
+ (let loop ((xs xs) (seed seed))
+ (if (null? xs) seed
+ (loop (cdr xs) (f (car xs) seed)))))
+ (define (fold2 f a b xs)
+ (let loop ((xs xs) (a a) (b b))
+ (if (null? xs) (values a b)
+ (call-with-values
+ (lambda () (f (car xs) a b))
+ (lambda (a b)
+ (loop (cdr xs) a b))))))
+ (define (reverse-map-with-seed f seed xs)
+ (fold2 (lambda (x ys seed)
+ (call-with-values
+ (lambda () (f x seed))
+ (lambda (y seed)
+ (values (cons y ys) seed))))
+ '() seed xs))
+ (syntax-case whole-expr ()
+ ((_ expr clause clauses ...)
+ (with-syntax ((key #'key))
+ #`(let ((key expr))
+ #,@(fold
+ (lambda (clause-builder tail)
+ (clause-builder tail))
+ #'()
+ (reverse-map-with-seed
+ (lambda (clause seen)
+ (define* (bad-clause #:optional (msg "invalid clause"))
+ (syntax-violation 'case msg whole-expr clause))
+ (syntax-case clause ()
+ ((test . rest)
+ (with-syntax
+ ((clause-expr
+ (syntax-case #'rest (=>)
+ ((=> receiver) #'(receiver key))
+ ((=> receiver ...)
+ (bad-clause
+ "wrong number of receiver expressions"))
+ ((e e* ...) #'(begin e e* ...))
+ (_ (bad-clause)))))
+ (syntax-case #'test (else)
+ ((datums ...)
+ (let ((seen
+ (fold
+ (lambda (datum seen)
+ (define (warn-datum type)
+ ((@ (system base message)
+ warning)
+ type
+ (append (source-properties datum)
+ (source-properties
+ (syntax->datum #'test)))
+ datum
+ (syntax->datum clause)
+ (syntax->datum whole-expr)))
+ (if (memv datum seen)
+ (warn-datum 'duplicate-case-datum))
+ (if (or (pair? datum)
+ (array? datum)
+ (generalized-vector? datum))
+ (warn-datum 'bad-case-datum))
+ (cons datum seen))
+ seen
+ (map syntax->datum #'(datums ...)))))
+ (values (lambda (tail)
+ #`((if (memv key '(datums ...))
+ clause-expr
+ #,@tail)))
+ seen)))
+ (else (values (lambda (tail)
+ (if (null? tail)
+ #'(clause-expr)
+ (bad-clause
+ "else must be the last clause")))
+ seen))
+ (_ (bad-clause)))))
+ (_ (bad-clause))))
+ '() #'(clause clauses ...)))))))))
(define-syntax do
(syntax-rules ()
((do "step" x y)
y)))
-(define-syntax delay
- (syntax-rules ()
- ((_ exp) (make-promise (lambda () exp)))))
-
-(include-from-path "ice-9/quasisyntax")
+(define-syntax-rule (delay exp)
+ (make-promise (lambda () exp)))
(define-syntax current-source-location
(lambda (x)
(with-syntax ((s (datum->syntax x (syntax-source x))))
#''s)))))
-(define-syntax define-once
- (syntax-rules ()
- ((_ sym val)
- (define sym
- (if (module-locally-bound? (current-module) 'sym) sym val)))))
+;; We provide this accessor out of convenience. current-line and
+;; current-column aren't so interesting, because they distort what they
+;; are measuring; better to use syntax-source from a macro.
+;;
+(define-syntax current-filename
+ (lambda (x)
+ "A macro that expands to the current filename: the filename that
+the (current-filename) form appears in. Expands to #f if this
+information is unavailable."
+ (false-if-exception
+ (canonicalize-path (assq-ref (syntax-source x) 'filename)))))
+
+(define-syntax-rule (define-once sym val)
+ (define sym
+ (if (module-locally-bound? (current-module) 'sym) sym val)))
+
+;;; The real versions of `map' and `for-each', with cycle detection, and
+;;; that use reverse! instead of recursion in the case of `map'.
+;;;
+(define map
+ (case-lambda
+ ((f l)
+ (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
+ (if (pair? hare)
+ (if move?
+ (if (eq? tortoise hare)
+ (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+ (list l) #f)
+ (map1 (cdr hare) (cdr tortoise) #f
+ (cons (f (car hare)) out)))
+ (map1 (cdr hare) tortoise #t
+ (cons (f (car hare)) out)))
+ (if (null? hare)
+ (reverse! out)
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l) #f)))))
+
+ ((f l1 l2)
+ (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
+ (cond
+ ((pair? h1)
+ (cond
+ ((not (pair? h2))
+ (scm-error 'wrong-type-arg "map"
+ (if (list? h2)
+ "List of wrong length: ~S"
+ "Not a list: ~S")
+ (list l2) #f))
+ ((not move?)
+ (map2 (cdr h1) (cdr h2) t1 t2 #t
+ (cons (f (car h1) (car h2)) out)))
+ ((eq? t1 h1)
+ (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+ (list l1) #f))
+ ((eq? t2 h2)
+ (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+ (list l2) #f))
+ (else
+ (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
+ (cons (f (car h1) (car h2)) out)))))
+
+ ((and (null? h1) (null? h2))
+ (reverse! out))
+
+ ((null? h1)
+ (scm-error 'wrong-type-arg "map"
+ (if (list? h2)
+ "List of wrong length: ~S"
+ "Not a list: ~S")
+ (list l2) #f))
+ (else
+ (scm-error 'wrong-type-arg "map"
+ "Not a list: ~S"
+ (list l1) #f)))))
+
+ ((f l1 . rest)
+ (let ((len (length l1)))
+ (let mapn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (mapn (cdr rest))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+ (let mapn ((l1 l1) (rest rest) (out '()))
+ (if (null? l1)
+ (reverse! out)
+ (mapn (cdr l1) (map cdr rest)
+ (cons (apply f (car l1) (map car rest)) out)))))))
+
+(define map-in-order map)
+
+(define for-each
+ (case-lambda
+ ((f l)
+ (let for-each1 ((hare l) (tortoise l) (move? #f))
+ (if (pair? hare)
+ (if move?
+ (if (eq? tortoise hare)
+ (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+ (list l) #f)
+ (begin
+ (f (car hare))
+ (for-each1 (cdr hare) (cdr tortoise) #f)))
+ (begin
+ (f (car hare))
+ (for-each1 (cdr hare) tortoise #t)))
+
+ (if (not (null? hare))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+ (list l) #f)))))
+
+ ((f l1 l2)
+ (let for-each2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f))
+ (cond
+ ((and (pair? h1) (pair? h2))
+ (cond
+ ((not move?)
+ (f (car h1) (car h2))
+ (for-each2 (cdr h1) (cdr h2) t1 t2 #t))
+ ((eq? t1 h1)
+ (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+ (list l1) #f))
+ ((eq? t2 h2)
+ (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+ (list l2) #f))
+ (else
+ (f (car h1) (car h2))
+ (for-each2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f))))
+
+ ((if (null? h1)
+ (or (null? h2) (pair? h2))
+ (and (pair? h1) (null? h2)))
+ (if #f #f))
+
+ ((list? h1)
+ (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
+ (list h2) #f))
+ (else
+ (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
+ (list h1) #f)))))
+
+ ((f l1 . rest)
+ (let ((len (length l1)))
+ (let for-eachn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (for-eachn (cdr rest))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+
+ (let for-eachn ((l1 l1) (rest rest))
+ (if (pair? l1)
+ (begin
+ (apply f (car l1) (map car rest))
+ (for-eachn (cdr l1) (map cdr rest))))))))
+
\f
(let ((filename (or (cadr source) "<unnamed port>"))
(line (caddr source))
(col (cdddr source)))
- (format port "~a:~a:~a: " filename line col))
+ (format port "~a:~a:~a: " filename (1+ line) col))
(format port "ERROR: "))))
(set! set-exception-printer!
((subr msg args . rest)
(if subr
(format port "In procedure ~a: " subr))
- (apply format port msg args))
+ (apply format port msg (or args '())))
(_ (default-printer)))
args))
(_ (default-printer)))
args))
+ (define (getaddrinfo-error-printer port key args default-printer)
+ (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
+
(set-exception-printer! 'goops-error scm-error-printer)
(set-exception-printer! 'host-not-found scm-error-printer)
(set-exception-printer! 'keyword-argument-error scm-error-printer)
(set-exception-printer! 'wrong-number-of-args scm-error-printer)
(set-exception-printer! 'wrong-type-arg scm-error-printer)
- (set-exception-printer! 'syntax-error syntax-error-printer))
+ (set-exception-printer! 'syntax-error syntax-error-printer)
+
+ (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer))
\f
(define (and=> value procedure) (and value (procedure value)))
(define call/cc call-with-current-continuation)
-(define-syntax false-if-exception
- (syntax-rules ()
- ((_ expr)
- (catch #t
- (lambda () expr)
- (lambda (k . args) #f)))))
+(define-syntax-rule (false-if-exception expr)
+ (catch #t
+ (lambda () expr)
+ (lambda (k . args) #f)))
\f
;; properties within the object itself.
(define (make-object-property)
- (define-syntax with-mutex
- (syntax-rules ()
- ((_ lock exp)
- (dynamic-wind (lambda () (lock-mutex lock))
- (lambda () exp)
- (lambda () (unlock-mutex lock))))))
- (let ((prop (make-weak-key-hash-table))
- (lock (make-mutex)))
+ ;; Weak tables are thread-safe.
+ (let ((prop (make-weak-key-hash-table)))
(make-procedure-with-setter
- (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
- (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+ (lambda (obj) (hashq-ref prop obj))
+ (lambda (obj val) (hashq-set! prop obj val)))))
\f
;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable
- ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
- ;; that we need to expose the bare vtable-vtable to Scheme.
- (make-vtable-vtable "prprpw" 0
- (lambda (s p)
- (cond ((eq? s record-type-vtable)
- (display "#<record-type-vtable>" p))
- (else
- (display "#<record-type " p)
- (display (record-type-name s) p)
- (display ">" p))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+ (lambda (s p)
+ (display "#<record-type " p)
+ (display (record-type-name s) p)
+ (display ">" p)))))
+ (set-struct-vtable-name! s 'record-type)
+ s))
(define (record-type? obj)
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
\f
-(if (provided? 'posix)
- (primitive-load-path "ice-9/posix"))
+;; Load `posix.scm' even when not (provided? 'posix) so that we get the
+;; `stat' accessors.
+(primitive-load-path "ice-9/posix")
(if (provided? 'socket)
(primitive-load-path "ice-9/networking"))
(thunk)))
(lambda (k . args)
(%start-stack tag (lambda () (apply k args)))))))
-(define-syntax start-stack
- (syntax-rules ()
- ((_ tag exp)
- (%start-stack tag (lambda () exp)))))
+
+(define-syntax-rule (start-stack tag exp)
+ (%start-stack tag (lambda () exp)))
\f
(start-stack 'load-stack
(primitive-load-path name)))
+(define-syntax-rule (add-to-load-path elt)
+ "Add ELT to Guile's load path, at compile-time and at run-time."
+ (eval-when (compile load eval)
+ (set! %load-path (cons elt %load-path))))
+
(define %load-verbosely #f)
(define (assert-load-verbosity v) (set! %load-verbosely v))
(define (%load-announce file)
(if %load-verbosely
- (with-output-to-port (current-error-port)
+ (with-output-to-port (current-warning-port)
(lambda ()
(display ";;; ")
(display "loading ")
;;; Reader code for various "#c" forms.
;;;
-(define read-eval? (make-fluid))
-(fluid-set! read-eval? #f)
+(define read-eval? (make-fluid #f))
(read-hash-extend #\.
(lambda (c port)
(if (fluid-ref read-eval?)
((define-record-type
(lambda (x)
(define (make-id scope . fragments)
- (datum->syntax #'scope
+ (datum->syntax scope
(apply symbol-append
(map (lambda (x)
(if (symbol? x) x (syntax->datum x)))
;; initial uses list, or binding procedure.
;;
(define* (make-module #:optional (size 31) (uses '()) (binder #f))
- (define %default-import-size
- ;; Typical number of imported bindings actually used by a module.
- 600)
-
(if (not (integer? size))
(error "Illegal size to make-module." size))
(if (not (and (list? uses)
(let ((module (module-constructor (make-hash-table size)
uses binder #f macroexpand
#f #f #f
- (make-hash-table %default-import-size)
+ (make-hash-table)
'()
(make-weak-key-hash-table 31) #f
(make-hash-table 7) #f #f #f)))
(define (module-define-submodule! module name submodule)
(hashq-set! (module-submodules module) name submodule))
-;; It used to be, however, that module names were also present in the
-;; value namespace. When we enable deprecated code, we preserve this
-;; legacy behavior.
-;;
-;; These shims are defined here instead of in deprecated.scm because we
-;; need their definitions before loading other modules.
-;;
-(begin-deprecated
- (define (module-ref-submodule module name)
- (or (hashq-ref (module-submodules module) name)
- (and (module-submodule-binder module)
- ((module-submodule-binder module) module name))
- (let ((var (module-local-variable module name)))
- (and var (variable-bound? var) (module? (variable-ref var))
- (begin
- (warn "module" module "not in submodules table")
- (variable-ref var))))))
-
- (define (module-define-submodule! module name submodule)
- (let ((var (module-local-variable module name)))
- (if (and var
- (or (not (variable-bound? var))
- (not (module? (variable-ref var)))))
- (warn "defining module" module ": not overriding local definition" var)
- (module-define! module name submodule)))
- (hashq-set! (module-submodules module) name submodule)))
-
\f
;;; {Module-based Loading}
;; Newly used modules must be appended rather than consed, so that
;; `module-variable' traverses the use list starting from the first
;; used module.
- (set-module-uses! module
- (append (filter (lambda (m)
- (not
- (equal? (module-name m)
- (module-name interface))))
- (module-uses module))
- (list interface)))
+ (set-module-uses! module (append (module-uses module)
+ (list interface)))
(hash-clear! (module-import-obarray module))
(module-modified module))))
;; MODULE-USE-INTERFACES! module interfaces
;;
-;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
+;; Same as MODULE-USE!, but only notifies module observers after all
+;; interfaces are added to the inports list.
;;
(define (module-use-interfaces! module interfaces)
- (let ((prev (filter (lambda (used)
- (and-map (lambda (iface)
- (not (equal? (module-name used)
- (module-name iface))))
- interfaces))
- (module-uses module))))
- (set-module-uses! module
- (append prev interfaces))
+ (let* ((cur (module-uses module))
+ (new (let lp ((in interfaces) (out '()))
+ (if (null? in)
+ (reverse out)
+ (lp (cdr in)
+ (let ((iface (car in)))
+ (if (or (memq iface cur) (memq iface out))
+ out
+ (cons iface out))))))))
+ (set-module-uses! module (append cur new))
(hash-clear! (module-import-obarray module))
(module-modified module)))
(error "expected list of integers for version"))
(set-module-version! module version)
(set-module-version! (module-public-interface module) version)))
- (if (pair? duplicates)
- (let ((handlers (lookup-duplicates-handlers duplicates)))
- (set-module-duplicates-handlers! module handlers)))
-
(let ((imports (resolve-imports imports)))
(call-with-deferred-observers
(lambda ()
(error "expected re-exports to be a list of symbols or symbol pairs"))
;; FIXME
(if (not (null? autoloads))
- (apply module-autoload! module autoloads)))))
+ (apply module-autoload! module autoloads))
+ ;; Wait until modules have been loaded to resolve duplicates
+ ;; handlers.
+ (if (pair? duplicates)
+ (let ((handlers (lookup-duplicates-handlers duplicates)))
+ (set-module-duplicates-handlers! module handlers))))))
(if transformer
(if (and (pair? transformer) (list-of symbol? transformer))
flags)
(interface options)
(interface)))
- (define-syntax option-set!
- (syntax-rules ()
- ((_ opt val)
- (eval-when (eval load compile expand)
- (options (append (options) (list 'opt val)))))))))))
+ (define-syntax-rule (option-set! opt val)
+ (eval-when (eval load compile expand)
+ (options (append (options) (list 'opt val)))))))))
(define-option-interface
(debug-options-interface
\f
+;;; {Parameters}
+;;;
+
+(define <parameter>
+ ;; Three fields: the procedure itself, the fluid, and the converter.
+ (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #:optional (conv (lambda (x) x)))
+ (let ((fluid (make-fluid (conv init))))
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv)))
+
+(define (parameter? x)
+ (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(define (parameter-fluid p)
+ (if (parameter? p)
+ (struct-ref p 1)
+ (scm-error 'wrong-type-arg "parameter-fluid"
+ "Not a parameter: ~S" (list p) #f)))
+
+(define (parameter-converter p)
+ (if (parameter? p)
+ (struct-ref p 2)
+ (scm-error 'wrong-type-arg "parameter-fluid"
+ "Not a parameter: ~S" (list p) #f)))
+
+(define-syntax parameterize
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((param value) ...) body body* ...)
+ (with-syntax (((p ...) (generate-temporaries #'(param ...))))
+ #'(let ((p param) ...)
+ (if (not (parameter? p))
+ (scm-error 'wrong-type-arg "parameterize"
+ "Not a parameter: ~S" (list p) #f))
+ ...
+ (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
+ ...)
+ body body* ...)))))))
+
+\f
+;;;
+;;; Current ports as parameters.
+;;;
+
+(let ((fluid->parameter
+ (lambda (fluid conv)
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv))))
+ (define-syntax-rule (port-parameterize! binding fluid predicate msg)
+ (begin
+ (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
+ (lambda (x)
+ (if (predicate x) x
+ (error msg x)))))
+ (module-remove! (current-module) 'fluid)))
+
+ (port-parameterize! current-input-port %current-input-port-fluid
+ input-port? "expected an input port")
+ (port-parameterize! current-output-port %current-output-port-fluid
+ output-port? "expected an output port")
+ (port-parameterize! current-error-port %current-error-port-fluid
+ output-port? "expected an output port"))
+
+
+\f
+;;;
+;;; Warnings.
+;;;
+
+(define current-warning-port
+ (make-parameter (current-error-port)
+ (lambda (x)
+ (if (output-port? x)
+ x
+ (error "expected an output port" x)))))
+
+
+\f
+
;;; {Running Repls}
;;;
-(define *repl-stack* (make-fluid))
+(define *repl-stack* (make-fluid '()))
;; Programs can call `batch-mode?' to see if they are running as part of a
;; script or if they are running interactively. REPL implementations ensure that
;; `batch-mode?' returns #f during their extent.
;;
(define (batch-mode?)
- (null? (or (fluid-ref *repl-stack*) '())))
+ (null? (fluid-ref *repl-stack*)))
;; Programs can re-enter batch mode, for example after a fork, by calling
;; `ensure-batch-mode!'. It's not a great interface, though; it would be better
(define repl-reader
(lambda* (prompt #:optional (reader (fluid-ref current-reader)))
(if (not (char-ready?))
- (display (if (string? prompt) prompt (prompt))))
+ (begin
+ (display (if (string? prompt) prompt (prompt)))
+ ;; An interesting situation. The printer resets the column to
+ ;; 0 by printing a newline, but we then advance it by printing
+ ;; the prompt. However the port-column of the output port
+ ;; does not typically correspond with the actual column on the
+ ;; screen, because the input is echoed back! Since the
+ ;; input is line-buffered and thus ends with a newline, the
+ ;; output will really start on column zero. So, here we zero
+ ;; it out. See bug 9664.
+ ;;
+ ;; Note that for similar reasons, the output-line will not
+ ;; reflect the actual line on the screen. But given the
+ ;; possibility of multiline input, the fix is not as
+ ;; straightforward, so we don't bother.
+ ;;
+ ;; Also note that the readline implementation papers over
+ ;; these concerns, because it's readline itself printing the
+ ;; prompt, and not Guile.
+ (set-port-column! (current-output-port) 0)))
(force-output)
(run-hook before-read-hook)
((or reader read) (current-input-port))))
(define-syntax #,(datum->syntax #'while 'break)
(lambda (x)
(syntax-case x ()
- ((_)
- #'(abort-to-prompt break-tag))
- ((_ . args)
- (syntax-violation 'break "too many arguments" x))
+ ((_ arg (... ...))
+ #'(abort-to-prompt break-tag arg (... ...)))
(_
- #'(lambda ()
- (abort-to-prompt break-tag))))))
+ #'(lambda args
+ (apply abort-to-prompt break-tag args))))))
(let lp ()
(call-with-prompt
continue-tag
(_
#'(lambda ()
(abort-to-prompt continue-tag))))))
- (do () ((not cond)) body ...))
+ (do () ((not cond) #f) body ...))
(lambda (k) (lp)))))
- (lambda (k)
- #t)))))))
+ (lambda (k . args)
+ (if (null? args)
+ #t
+ (apply values args)))))))))
\f
#`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
((#:use-module (name name* ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
- (parse #'args (cons #'((name name* ...)) imp) exp rex rep aut))
+ (parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut))
((#:use-syntax (name name* ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
#`(#:transformer '(name name* ...)
- . #,(parse #'args (cons #'((name name* ...)) imp) exp rex rep aut)))
+ . #,(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut)))
((#:use-module ((name name* ...) arg ...) . args)
(and (and-map symbol? (syntax->datum #'(name name* ...))))
(parse #'args
- (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
+ #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
exp rex rep aut))
((#:export (ex ...) . args)
(parse #'args imp #`(#,@exp ex ...) rex rep aut))
(process-use-modules (list quoted-args ...))
*unspecified*))))))
-(define-syntax use-syntax
- (syntax-rules ()
- ((_ spec ...)
- (begin
- (eval-when (eval load compile expand)
- (issue-deprecation-warning
- "`use-syntax' is deprecated. Please contact guile-devel for more info."))
- (use-modules spec ...)))))
-
(include-from-path "ice-9/r6rs-libraries")
-(define-syntax define-private
- (syntax-rules ()
- ((_ foo bar)
- (define foo bar))))
+(define-syntax-rule (define-private foo bar)
+ (define foo bar))
(define-syntax define-public
(syntax-rules ()
(define name val)
(export name)))))
-(define-syntax defmacro-public
- (syntax-rules ()
- ((_ name args . body)
- (begin
- (defmacro name args . body)
- (export-syntax name)))))
+(define-syntax-rule (defmacro-public name args body ...)
+ (begin
+ (defmacro name args body ...)
+ (export-syntax name)))
;; And now for the most important macro.
-(define-syntax λ
- (syntax-rules ()
- ((_ formals body ...)
- (lambda formals body ...))))
+(define-syntax-rule (λ formals body ...)
+ (lambda formals body ...))
\f
;; Export a local variable
(let* ((internal-name (if (pair? name) (car name) name))
(external-name (if (pair? name) (cdr name) name))
(var (module-ensure-local-variable! m internal-name)))
+ ;; FIXME: use a bit on variables instead of object
+ ;; properties.
(set-object-property! var 'replace #t)
(module-add! public-i external-name var)))
names)))
(module-add! public-i external-name var)))))
names)))
-(define-syntax export
- (syntax-rules ()
- ((_ name ...)
- (eval-when (eval load compile expand)
- (call-with-deferred-observers
- (lambda ()
- (module-export! (current-module) '(name ...))))))))
+(define-syntax-rule (export name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-export! (current-module) '(name ...))))))
-(define-syntax re-export
- (syntax-rules ()
- ((_ name ...)
- (eval-when (eval load compile expand)
- (call-with-deferred-observers
- (lambda ()
- (module-re-export! (current-module) '(name ...))))))))
+(define-syntax-rule (re-export name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-re-export! (current-module) '(name ...))))))
-(define-syntax export!
- (syntax-rules ()
- ((_ name ...)
- (eval-when (eval load compile expand)
- (call-with-deferred-observers
- (lambda ()
- (module-replace! (current-module) '(name ...))))))))
+(define-syntax-rule (export! name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-replace! (current-module) '(name ...))))))
-(define-syntax export-syntax
- (syntax-rules ()
- ((_ name ...)
- (export name ...))))
+(define-syntax-rule (export-syntax name ...)
+ (export name ...))
-(define-syntax re-export-syntax
- (syntax-rules ()
- ((_ name ...)
- (re-export name ...))))
+(define-syntax-rule (re-export-syntax name ...)
+ (re-export name ...))
\f
;;;
(define* (make-mutable-parameter init #:optional (converter identity))
- (let ((fluid (make-fluid)))
- (fluid-set! fluid (converter init))
+ (let ((fluid (make-fluid (converter init))))
(case-lambda
(() (fluid-ref fluid))
((val) (fluid-set! fluid (converter val))))))
#f))
(define (warn module name int1 val1 int2 val2 var val)
- (format (current-error-port)
+ (format (current-warning-port)
"WARNING: ~A: `~A' imported from both ~A and ~A\n"
(module-name module)
name
(define (warn-override-core module name int1 val1 int2 val2 var val)
(and (eq? int1 the-scm-module)
(begin
- (format (current-error-port)
+ (format (current-warning-port)
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
(module-name module)
(module-name int2)
;;; {`load'.}
;;;
;;; Load is tricky when combined with relative paths, compilation, and
-;;; the filesystem. If a path is relative, what is it relative to? The
+;;; the file system. If a path is relative, what is it relative to? The
;;; path of the source file at the time it was compiled? The path of
;;; the compiled file? What if both or either were installed? And how
;;; do you get that information? Tricky, I say.
(define %auto-compilation-options
;; Default `compile-file' option when auto-compiling.
- '(#:warnings (unbound-variable arity-mismatch)))
+ '(#:warnings (unbound-variable arity-mismatch format)))
(define* (load-in-vicinity dir path #:optional reader)
+ (define (canonical->suffix canon)
+ (cond
+ ((string-prefix? "/" canon) canon)
+ ((and (> (string-length canon) 2)
+ (eqv? (string-ref canon 1) #\:))
+ ;; Paths like C:... transform to /C...
+ (string-append "/" (substring canon 0 1) (substring canon 2)))
+ (else canon)))
+
;; Returns the .go file corresponding to `name'. Does not search load
;; paths, only the fallback path. If the .go file is missing or out of
;; date, and auto-compilation is enabled, will try auto-compilation, just
;; partially duplicates functionality from (system base compile).
;;
(define (compiled-file-name canon-path)
+ ;; FIXME: would probably be better just to append SHA1(canon-path)
+ ;; to the %compile-fallback-path, to avoid deep directory stats.
(and %compile-fallback-path
(string-append
%compile-fallback-path
- ;; no need for '/' separator here, canon-path is absolute
- canon-path
+ (canonical->suffix canon-path)
(cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions)))
(warn "invalid %load-compiled-extensions"
(catch #t
(lambda ()
(let* ((scmstat (stat name))
- (gostat (stat go-path #f)))
+ (gostat (and (not %fresh-auto-compile)
+ (stat go-path #f))))
(if (and gostat
(or (> (stat:mtime gostat) (stat:mtime scmstat))
(and (= (stat:mtime gostat) (stat:mtime scmstat))
go-path
(begin
(if gostat
- (format (current-error-port)
+ (format (current-warning-port)
";;; note: source file ~a\n;;; newer than compiled ~a\n"
name go-path))
(cond
(%load-should-auto-compile
(%warn-auto-compilation-enabled)
- (format (current-error-port) ";;; compiling ~a\n" name)
+ (format (current-warning-port) ";;; compiling ~a\n" name)
(let ((cfn
((module-ref
(resolve-interface '(system base compile))
name
#:opts %auto-compilation-options
#:env (current-module))))
- (format (current-error-port) ";;; compiled ~a\n" cfn)
+ (format (current-warning-port) ";;; compiled ~a\n" cfn)
cfn))
(else #f))))))
(lambda (k . args)
- (format (current-error-port)
- ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
- name k args)
+ (format (current-warning-port)
+ ";;; WARNING: compilation of ~a failed:\n" name)
+ (for-each (lambda (s)
+ (if (not (string-null? s))
+ (format (current-warning-port) ";;; ~a\n" s)))
+ (string-split
+ (call-with-output-string
+ (lambda (port) (print-exception port #f k args)))
+ #\newline))
#f)))
(define (absolute-path? path)
(and go-path
(fresh-compiled-file-name abs-path go-path)))))))
(if cfn
- (load-compiled cfn)
+ (begin
+ (if %load-hook
+ (%load-hook abs-path))
+ (load-compiled cfn))
(start-stack 'load-stack
(primitive-load abs-path)))))
srfi-6 ;; open-input-string etc, in the guile core
srfi-13 ;; string library
srfi-14 ;; character sets
+ srfi-23 ;; `error` procedure
+ srfi-39 ;; parameterize
srfi-55 ;; require-extension
srfi-61 ;; general cond clause
))
x)))))
\f
+;;; Defining transparently inlinable procedures
+;;;
+
+(define-syntax define-inlinable
+ ;; Define a macro and a procedure such that direct calls are inlined, via
+ ;; the macro expansion, whereas references in non-call contexts refer to
+ ;; the procedure. Inspired by the `define-integrable' macro by Dybvig et al.
+ (lambda (x)
+ ;; Use a space in the prefix to avoid potential -Wunused-toplevel
+ ;; warning
+ (define prefix (string->symbol "% "))
+ (define (make-procedure-name name)
+ (datum->syntax name
+ (symbol-append prefix (syntax->datum name)
+ '-procedure)))
+
+ (syntax-case x ()
+ ((_ (name formals ...) body ...)
+ (identifier? #'name)
+ (with-syntax ((proc-name (make-procedure-name #'name))
+ ((args ...) (generate-temporaries #'(formals ...))))
+ #`(begin
+ (define (proc-name formals ...)
+ (syntax-parameterize ((name (identifier-syntax proc-name)))
+ body ...))
+ (define-syntax-parameter name
+ (lambda (x)
+ (syntax-case x ()
+ ((_ args ...)
+ #'((syntax-parameterize ((name (identifier-syntax proc-name)))
+ (lambda (formals ...)
+ body ...))
+ args ...))
+ (_
+ (identifier? x)
+ #'proc-name))))))))))
+
+\f
(define using-readline?
(let ((using-readline? (make-fluid)))
\f
-;;; Place the user in the guile-user module.
+;;; SRFI-4 in the default environment. FIXME: we should figure out how
+;;; to deprecate this.
;;;
;; FIXME:
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
+\f
+
+;;; A few identifiers that need to be defined in this file are really
+;;; internal implementation details. We shove them off into internal
+;;; modules, removing them from the (guile) module.
+;;;
+
+(define-module (system syntax))
+
+(let ()
+ (define (steal-bindings! from to ids)
+ (for-each
+ (lambda (sym)
+ (let ((v (module-local-variable from sym)))
+ (module-remove! from sym)
+ (module-add! to sym v)))
+ ids)
+ (module-export! to ids))
+
+ (steal-bindings! the-root-module (resolve-module '(system syntax))
+ '(syntax-local-binding
+ syntax-module
+ syntax-locally-bound-identifiers
+ syntax-session-id)))
+
+
+\f
+
+;;; Place the user in the guile-user module.
+;;;
+
;; Set filename to #f to prevent reload.
(define-module (guile-user)
#:autoload (system base compile) (compile compile-file)