;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
-;;;; 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))
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...) ...)
;; have booted.
(define (module-name x)
'(guile))
+(define (module-add! module sym var)
+ (hashq-set! (%get-pre-modules-obarray) sym var))
(define (module-define! module sym val)
(let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
(if v
(variable-set! v val)
- (hashq-set! (%get-pre-modules-obarray) sym
- (make-variable val)))))
+ (module-add! (current-module) sym (make-variable val)))))
(define (module-ref module sym)
(let ((v (module-variable module sym)))
(if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
((do "step" x y)
y)))
-(define-syntax delay
- (syntax-rules ()
- ((_ exp) (make-promise (lambda () exp)))))
+(define-syntax-rule (delay exp)
+ (make-promise (lambda () exp)))
(include-from-path "ice-9/quasisyntax")
(with-syntax ((s (datum->syntax x (syntax-source x))))
#''s)))))
+(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
+
+;;;
+;;; Extensible exception printing.
+;;;
+
+(define set-exception-printer! #f)
+;; There is already a definition of print-exception from backtrace.c
+;; that we will override.
+
+(let ((exception-printers '()))
+ (define (print-location frame port)
+ (let ((source (and=> frame frame-source)))
+ ;; source := (addr . (filename . (line . column)))
+ (if source
+ (let ((filename (or (cadr source) "<unnamed port>"))
+ (line (caddr source))
+ (col (cdddr source)))
+ (format port "~a:~a:~a: " filename (1+ line) col))
+ (format port "ERROR: "))))
+
+ (set! set-exception-printer!
+ (lambda (key proc)
+ (set! exception-printers (acons key proc exception-printers))))
+
+ (set! print-exception
+ (lambda (port frame key args)
+ (define (default-printer)
+ (format port "Throw to key `~a' with args `~s'." key args))
+
+ (if frame
+ (let ((proc (frame-procedure frame)))
+ (print-location frame port)
+ (format port "In procedure ~a:\n"
+ (or (procedure-name proc) proc))))
+
+ (print-location frame port)
+ (catch #t
+ (lambda ()
+ (let ((printer (assq-ref exception-printers key)))
+ (if printer
+ (printer port key args default-printer)
+ (default-printer))))
+ (lambda (k . args)
+ (format port "Error while printing exception.")))
+ (newline port)
+ (force-output port))))
+
+;;;
+;;; Printers for those keys thrown by Guile.
+;;;
+(let ()
+ (define (scm-error-printer port key args default-printer)
+ ;; Abuse case-lambda as a pattern matcher, given that we don't have
+ ;; ice-9 match at this point.
+ (apply (case-lambda
+ ((subr msg args . rest)
+ (if subr
+ (format port "In procedure ~a: " subr))
+ (apply format port msg (or args '())))
+ (_ (default-printer)))
+ args))
+
+ (define (syntax-error-printer port key args default-printer)
+ (apply (case-lambda
+ ((who what where form subform . extra)
+ (format port "Syntax error:\n")
+ (if where
+ (let ((file (or (assq-ref where 'filename) "unknown file"))
+ (line (and=> (assq-ref where 'line) 1+))
+ (col (assq-ref where 'column)))
+ (format port "~a:~a:~a: " file line col))
+ (format port "unknown location: "))
+ (if who
+ (format port "~a: " who))
+ (format port "~a" what)
+ (if subform
+ (format port " in subform ~s of ~s" subform form)
+ (if form
+ (format port " in form ~s" form))))
+ (_ (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! 'misc-error scm-error-printer)
+ (set-exception-printer! 'no-data scm-error-printer)
+ (set-exception-printer! 'no-recovery scm-error-printer)
+ (set-exception-printer! 'null-pointer-error scm-error-printer)
+ (set-exception-printer! 'out-of-range scm-error-printer)
+ (set-exception-printer! 'program-error scm-error-printer)
+ (set-exception-printer! 'read-error scm-error-printer)
+ (set-exception-printer! 'regular-expression-syntax scm-error-printer)
+ (set-exception-printer! 'signal scm-error-printer)
+ (set-exception-printer! 'stack-overflow scm-error-printer)
+ (set-exception-printer! 'system-error scm-error-printer)
+ (set-exception-printer! 'try-again scm-error-printer)
+ (set-exception-printer! 'unbound-variable 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! 'getaddrinfo-error getaddrinfo-error-printer))
+
\f
;;;
(define (identity x) x)
+
+(define (compose proc . rest)
+ "Compose PROC with the procedures in REST, such that the last one in
+REST is applied first and PROC last, and return the resulting procedure.
+The given procedures must have compatible arity."
+ (if (null? rest)
+ proc
+ (let ((g (apply compose rest)))
+ (lambda args
+ (call-with-values (lambda () (apply g args)) proc)))))
+
+(define (negate proc)
+ "Return a procedure with the same arity as PROC that returns the `not'
+of PROC's result."
+ (lambda args
+ (not (apply proc args))))
+
+(define (const value)
+ "Return a procedure that accepts any number of arguments and returns
+VALUE."
+ (lambda _
+ value))
+
(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)
- (let ((prop (primitive-make-property #f)))
+ (define-syntax-rule (with-mutex lock exp)
+ (dynamic-wind (lambda () (lock-mutex lock))
+ (lambda () exp)
+ (lambda () (unlock-mutex lock))))
+ (let ((prop (make-weak-key-hash-table))
+ (lock (make-mutex)))
(make-procedure-with-setter
- (lambda (obj) (primitive-property-ref prop obj))
- (lambda (obj val) (primitive-property-set! prop obj val)))))
+ (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
+ (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+
\f
\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"))
;; This is mostly for the internal use of the code generated by
;; scm_compile_shell_switches.
-(define (turn-on-debugging)
- (debug-enable 'debug)
- (debug-enable 'backtrace)
- (read-enable 'positions))
-
(define (load-user-init)
(let* ((home (or (getenv "HOME")
(false-if-exception (passwd:dir (getpwuid (getuid))))
(or (fluid-ref %stacks) '()))))
(thunk)))
(lambda (k . args)
- (%start-stack tag (lambda () (apply k args)))))))
-(define-syntax start-stack
- (syntax-rules ()
- ((_ tag exp)
- (%start-stack tag (lambda () exp)))))
+ (%start-stack tag (lambda () (apply k args)))))))
+
+(define-syntax-rule (start-stack tag exp)
+ (%start-stack tag (lambda () exp)))
\f
(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 ")
(set! %load-hook %load-announce)
-(define* (load name #:optional reader)
- ;; 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 autocompilation is enabled, will try autocompilation, just
- ;; as primitive-load-path does internally. primitive-load is
- ;; unaffected. Returns #f if autocompilation failed or was disabled.
- ;;
- ;; NB: Unless we need to compile the file, this function should not cause
- ;; (system base compile) to be loaded up. For that reason compiled-file-name
- ;; partially duplicates functionality from (system base compile).
- (define (compiled-file-name canon-path)
- (and %compile-fallback-path
- (string-append
- %compile-fallback-path
- ;; no need for '/' separator here, canon-path is absolute
- canon-path
- (cond ((or (null? %load-compiled-extensions)
- (string-null? (car %load-compiled-extensions)))
- (warn "invalid %load-compiled-extensions"
- %load-compiled-extensions)
- ".go")
- (else (car %load-compiled-extensions))))))
- (define (fresh-compiled-file-name go-path)
- (catch #t
- (lambda ()
- (let* ((scmstat (stat name))
- (gostat (stat go-path #f)))
- (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
- go-path
- (begin
- (if gostat
- (format (current-error-port)
- ";;; note: source file ~a\n;;; newer than compiled ~a\n"
- name go-path))
- (cond
- (%load-should-autocompile
- (%warn-autocompilation-enabled)
- (format (current-error-port) ";;; compiling ~a\n" name)
- ;; This use of @ is (ironically?) boot-safe, as modules have
- ;; not been booted yet, so the resolve-module call in psyntax
- ;; doesn't try to load a module, and compile-file will be
- ;; treated as a function, not a macro.
- (let ((cfn ((@ (system base compile) compile-file) name
- #:env (current-module))))
- (format (current-error-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)
- #f)))
- (with-fluids ((current-reader reader))
- (let ((cfn (and=> (and=> (false-if-exception (canonicalize-path name))
- compiled-file-name)
- fresh-compiled-file-name)))
- (if cfn
- (load-compiled cfn)
- (start-stack 'load-stack
- (primitive-load name))))))
-
\f
;;; {Reader Extensions}
;;; 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?)
;; Create a new module, perhaps with a particular size of obarray,
;; initial uses list, or binding procedure.
;;
-(define make-module
- (lambda args
-
- (define (parse-arg index default)
- (if (> (length args) index)
- (list-ref args index)
- default))
-
- (define %default-import-size
- ;; Typical number of imported bindings actually used by a module.
- 600)
-
- (if (> (length args) 3)
- (error "Too many args to make-module." args))
-
- (let ((size (parse-arg 0 31))
- (uses (parse-arg 1 '()))
- (binder (parse-arg 2 #f)))
-
- (if (not (integer? size))
- (error "Illegal size to make-module." size))
- (if (not (and (list? uses)
- (and-map module? uses)))
- (error "Incorrect use list." uses))
- (if (and binder (not (procedure? binder)))
- (error
- "Lazy-binder expected to be a procedure or #f." binder))
-
- (let ((module (module-constructor (make-hash-table size)
- uses binder #f macroexpand
- #f #f #f
- (make-hash-table %default-import-size)
- '()
- (make-weak-key-hash-table 31) #f
- (make-hash-table 7) #f #f #f)))
-
- ;; We can't pass this as an argument to module-constructor,
- ;; because we need it to close over a pointer to the module
- ;; itself.
- (set-module-eval-closure! module (standard-eval-closure module))
+(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)
+ (and-map module? uses)))
+ (error "Incorrect use list." uses))
+ (if (and binder (not (procedure? binder)))
+ (error
+ "Lazy-binder expected to be a procedure or #f." binder))
+
+ (let ((module (module-constructor (make-hash-table size)
+ uses binder #f macroexpand
+ #f #f #f
+ (make-hash-table %default-import-size)
+ '()
+ (make-weak-key-hash-table 31) #f
+ (make-hash-table 7) #f #f #f)))
+
+ ;; We can't pass this as an argument to module-constructor,
+ ;; because we need it to close over a pointer to the module
+ ;; itself.
+ (set-module-eval-closure! module (standard-eval-closure module))
- module))))
+ module))
\f
(define (module-define-submodule! module name submodule)
(hashq-set! (module-submodules module) name submodule))
-\f
-
-;;; {Low Level Bootstrapping}
-;;;
-
-;; make-root-module
-
-;; A root module uses the pre-modules-obarray as its obarray. This
-;; special obarray accumulates all bindings that have been established
-;; before the module system is fully booted.
+;; 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.
;;
-;; (The obarray continues to be used by code that has been closed over
-;; before the module system has been booted.)
-
-(define (make-root-module)
- (let ((m (make-module 0)))
- (set-module-obarray! m (%get-pre-modules-obarray))
- m))
-
-;; make-scm-module
-
-;; The root interface is a module that uses the same obarray as the
-;; root module. It does not allow new definitions, tho.
-
-(define (make-scm-module)
- (let ((m (make-module 0)))
- (set-module-obarray! m (%get-pre-modules-obarray))
- (set-module-eval-closure! m (standard-interface-eval-closure m))
- m))
-
+;; 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
(set-current-module outer-module)
(set! outer-module #f)))))
-(define basic-load load)
-
-(define* (load-module filename #:optional 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)
- reader)))))
-
-
\f
;;; {MODULE-REF -- exported}
;; 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)
- (set-module-uses! module
- (append (module-uses module) interfaces))
- (hash-clear! (module-import-obarray module))
- (module-modified module))
+ (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)))
\f
(loop cur (car tail) (cdr tail)))))))
-(define (local-ref names) (nested-ref (current-module) names))
-(define (local-set! names val) (nested-set! (current-module) names val))
-(define (local-define names val) (nested-define! (current-module) names val))
-(define (local-remove names) (nested-remove! (current-module) names))
-(define (local-ref-module names) (nested-ref-module (current-module) names))
-(define (local-define-module names mod) (nested-define-module! (current-module) names mod))
+(define (local-ref names)
+ (nested-ref (current-module) names))
+
+(define (local-set! names val)
+ (nested-set! (current-module) names val))
+
+(define (local-define names val)
+ (nested-define! (current-module) names val))
+
+(define (local-remove names)
+ (nested-remove! (current-module) names))
+
+(define (local-ref-module names)
+ (nested-ref-module (current-module) names))
+
+(define (local-define-module names mod)
+ (nested-define-module! (current-module) names mod))
(define (set-system-module! m s)
(set-procedure-property! (module-eval-closure m) 'system-module s))
-(define the-root-module (make-root-module))
-(define the-scm-module (make-scm-module))
-(set-module-public-interface! the-root-module the-scm-module)
-(set-module-name! the-root-module '(guile))
-(set-module-name! the-scm-module '(guile))
-(set-module-kind! the-scm-module 'interface)
-(set-system-module! the-root-module #t)
-(set-system-module! the-scm-module #t)
+;; The root module uses the pre-modules-obarray as its obarray. This
+;; special obarray accumulates all bindings that have been established
+;; before the module system is fully booted.
+;;
+;; (The obarray continues to be used by code that has been closed over
+;; before the module system has been booted.)
+;;
+(define the-root-module
+ (let ((m (make-module 0)))
+ (set-module-obarray! m (%get-pre-modules-obarray))
+ (set-module-name! m '(guile))
+ (set-system-module! m #t)
+ m))
+
+;; The root interface is a module that uses the same obarray as the
+;; root module. It does not allow new definitions, tho.
+;;
+(define the-scm-module
+ (let ((m (make-module 0)))
+ (set-module-obarray! m (%get-pre-modules-obarray))
+ (set-module-eval-closure! m (standard-interface-eval-closure m))
+ (set-module-name! m '(guile))
+ (set-module-kind! m 'interface)
+ (set-system-module! m #t)
+
+ ;; In Guile 1.8 and earlier M was its own public interface.
+ (set-module-public-interface! m m)
+
+ m))
+
+(set-module-public-interface! the-root-module the-scm-module)
\f
;; Cheat. These bindings are needed by modules.c, but we don't want
;; to move their real definition here because that would be unnatural.
;;
-(define process-define-module #f)
+(define define-module* #f)
(define process-use-modules #f)
(define module-export! #f)
(define default-duplicate-binding-procedures #f)
(define (try-load-module name version)
(try-module-autoload name version))
+(define (reload-module m)
+ "Revisit the source file corresponding to the module @var{m}."
+ (let ((f (module-filename m)))
+ (if f
+ (save-module-excursion
+ (lambda ()
+ ;; Re-set the initial environment, as in try-module-autoload.
+ (set-current-module (make-fresh-user-module))
+ (primitive-load-path f)
+ m))
+ ;; Though we could guess, we *should* know it.
+ (error "unknown file name for module" m))))
+
(define (purify-module! module)
"Removes bindings in MODULE which are inherited from the (guile) module."
(let ((use-list (module-uses module)))
;; This function is called from "modules.c". If you change it, be
;; sure to update "modules.c" as well.
-(define (process-define-module args)
- (let* ((module-id (car args))
- (module (resolve-module module-id #f))
- (kws (cdr args))
- (unrecognized (lambda (arg)
- (error "unrecognized define-module argument" arg))))
+(define* (define-module* name
+ #:key filename pure version (duplicates '())
+ (imports '()) (exports '()) (replacements '())
+ (re-exports '()) (autoloads '()) transformer)
+ (define (list-of pred l)
+ (or (null? l)
+ (and (pair? l) (pred (car l)) (list-of pred (cdr l)))))
+ (define (valid-export? x)
+ (or (symbol? x) (and (pair? x) (symbol? (car x)) (symbol? (cdr x)))))
+ (define (valid-autoload? x)
+ (and (pair? x) (list-of symbol? (car x)) (list-of symbol? (cdr x))))
+
+ (define (resolve-imports imports)
+ (define (resolve-import import-spec)
+ (if (list? import-spec)
+ (apply resolve-interface import-spec)
+ (error "unexpected use-module specification" import-spec)))
+ (let lp ((imports imports) (out '()))
+ (cond
+ ((null? imports) (reverse! out))
+ ((pair? imports)
+ (lp (cdr imports)
+ (cons (resolve-import (car imports)) out)))
+ (else (error "unexpected tail of imports list" imports)))))
+
+ ;; We could add a #:no-check arg, set by the define-module macro, if
+ ;; these checks are taking too much time.
+ ;;
+ (let ((module (resolve-module name #f)))
(beautify-user-module! module)
- (let loop ((kws kws)
- (reversed-interfaces '())
- (exports '())
- (re-exports '())
- (replacements '())
- (autoloads '()))
-
- (if (null? kws)
- (call-with-deferred-observers
- (lambda ()
- (module-use-interfaces! module (reverse reversed-interfaces))
- (module-export! module exports)
- (module-replace! module replacements)
- (module-re-export! module re-exports)
- (if (not (null? autoloads))
- (apply module-autoload! module autoloads))))
- (case (car kws)
- ((#:use-module #:use-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (cond
- ((equal? (caadr kws) '(ice-9 syncase))
- (issue-deprecation-warning
- "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
- (loop (cddr kws)
- reversed-interfaces
- exports
- re-exports
- replacements
- autoloads))
- (else
- (let* ((interface-args (cadr kws))
- (interface (apply resolve-interface interface-args)))
- (and (eq? (car kws) #:use-syntax)
- (or (symbol? (caar interface-args))
- (error "invalid module name for use-syntax"
- (car interface-args)))
- (set-module-transformer!
- module
- (module-ref interface
- (car (last-pair (car interface-args)))
- #f)))
- (loop (cddr kws)
- (cons interface reversed-interfaces)
- exports
- re-exports
- replacements
- autoloads)))))
- ((#:autoload)
- (or (and (pair? (cdr kws)) (pair? (cddr kws)))
- (unrecognized kws))
- (loop (cdddr kws)
- reversed-interfaces
- exports
- re-exports
- replacements
- (let ((name (cadr kws))
- (bindings (caddr kws)))
- (cons* name bindings autoloads))))
- ((#:no-backtrace)
- (set-system-module! module #t)
- (loop (cdr kws) reversed-interfaces exports re-exports
- replacements autoloads))
- ((#:pure)
- (purify-module! module)
- (loop (cdr kws) reversed-interfaces exports re-exports
- replacements autoloads))
- ((#:version)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (let ((version (cadr kws)))
- (set-module-version! module version)
- (set-module-version! (module-public-interface module) version))
- (loop (cddr kws) reversed-interfaces exports re-exports
- replacements autoloads))
- ((#:duplicates)
- (if (not (pair? (cdr kws)))
- (unrecognized kws))
- (set-module-duplicates-handlers!
- module
- (lookup-duplicates-handlers (cadr kws)))
- (loop (cddr kws) reversed-interfaces exports re-exports
- replacements autoloads))
- ((#:export #:export-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- (append (cadr kws) exports)
- re-exports
- replacements
- autoloads))
- ((#:re-export #:re-export-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- exports
- (append (cadr kws) re-exports)
- replacements
- autoloads))
- ((#:replace #:replace-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- exports
- re-exports
- (append (cadr kws) replacements)
- autoloads))
- ((#:filename)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (set-module-filename! module (cadr kws))
- (loop (cddr kws)
- reversed-interfaces
- exports
- re-exports
- replacements
- autoloads))
- (else
- (unrecognized kws)))))
+ (if filename
+ (set-module-filename! module filename))
+ (if pure
+ (purify-module! module))
+ (if version
+ (begin
+ (if (not (list-of integer? version))
+ (error "expected list of integers for version"))
+ (set-module-version! module version)
+ (set-module-version! (module-public-interface module) version)))
+ (let ((imports (resolve-imports imports)))
+ (call-with-deferred-observers
+ (lambda ()
+ (if (pair? imports)
+ (module-use-interfaces! module imports))
+ (if (list-of valid-export? exports)
+ (if (pair? exports)
+ (module-export! module exports))
+ (error "expected exports to be a list of symbols or symbol pairs"))
+ (if (list-of valid-export? replacements)
+ (if (pair? replacements)
+ (module-replace! module replacements))
+ (error "expected replacements to be a list of symbols or symbol pairs"))
+ (if (list-of valid-export? re-exports)
+ (if (pair? re-exports)
+ (module-re-export! module re-exports))
+ (error "expected re-exports to be a list of symbols or symbol pairs"))
+ ;; FIXME
+ (if (not (null? 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))
+ (let ((iface (resolve-interface transformer))
+ (sym (car (last-pair transformer))))
+ (set-module-transformer! module (module-ref iface sym)))
+ (error "expected transformer to be a module name" transformer)))
+
(run-hook module-defined-hook module)
module))
;; Here we could allow some other search strategy (other than
;; primitive-load-path), for example using versions encoded
;; into the file system -- but then we would have to figure
- ;; out how to locate the compiled file, do autocompilation,
+ ;; out how to locate the compiled file, do auto-compilation,
;; etc. Punt for now, and don't use versions when locating
;; the file.
(primitive-load-path (in-vicinity dir-hint name) #f)
flags)
(interface options)
(interface)))
- (define-syntax option-set!
- (syntax-rules ()
- ((_ opt val)
- (options (append (options) (list 'opt val))))))))))
-
-(define-option-interface
- (eval-options-interface
- (eval-options eval-enable eval-disable)
- (eval-set!)))
+ (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
(debug-options debug-enable debug-disable)
(debug-set!)))
-(define-option-interface
- (evaluator-traps-interface
- (traps trap-enable trap-disable)
- (trap-set!)))
-
(define-option-interface
(read-options-interface
(read-options read-enable read-disable)
\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 '()))
+
;; 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? (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
;; to abort to the outermost prompt, and call a thunk there.
-(define *repl-level* (make-fluid))
-(define (batch-mode?)
- (negative? (or (fluid-ref *repl-level*) -1)))
+;;
(define (ensure-batch-mode!)
- (fluid-set! *repl-level* #f))
+ (set! batch-mode? (lambda () #t)))
(define (quit . args)
(apply throw 'quit args))
(define before-print-hook (make-hook 1))
(define after-print-hook (make-hook 1))
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
;;; The default repl-reader function. We may override this if we've
;;; the readline library.
(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
((_ . args)
(syntax-violation 'continue "too many arguments" x))
(_
- #'(lambda args
- (apply abort-to-prompt continue-tag args))))))
- (do () ((not cond)) body ...))
+ #'(lambda ()
+ (abort-to-prompt continue-tag))))))
+ (do () ((not cond) #f) body ...))
(lambda (k) (lp)))))
- (lambda (k)
- #t)))))))
+ (lambda (k . args)
+ (if (null? args)
+ #t
+ (apply values args)))))))))
\f
;; Return a list of expressions that evaluate to the appropriate
;; arguments for resolve-interface according to SPEC.
-(eval-when
- (compile)
- (if (memq 'prefix (read-options))
- (error "boot-9 must be compiled with #:kw, not :kw")))
+(eval-when (compile)
+ (if (memq 'prefix (read-options))
+ (error "boot-9 must be compiled with #:kw, not :kw")))
(define (keyword-like-symbol->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
-;; FIXME: we really need to clean up the guts of the module system.
-;; We can compile to something better than process-define-module.
(define-syntax define-module
(lambda (x)
(define (keyword-like? stx)
(define (->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
- (define (quotify-iface args)
+ (define (parse-iface args)
(let loop ((in args) (out '()))
(syntax-case in ()
(() (reverse! out))
((kw . in) (not (keyword? (syntax->datum #'kw)))
(syntax-violation 'define-module "expected keyword arg" x #'kw))
((#:renamer renamer . in)
- (loop #'in (cons* #'renamer #:renamer out)))
+ (loop #'in (cons* #',renamer #:renamer out)))
((kw val . in)
- (loop #'in (cons* #''val #'kw out))))))
+ (loop #'in (cons* #'val #'kw out))))))
- (define (quotify args)
+ (define (parse args imp exp rex rep aut)
;; Just quote everything except #:use-module and #:use-syntax. We
;; need to know about all arguments regardless since we want to turn
;; symbols that look like keywords into real keywords, and the
;; keyword args in a define-module form are not regular
;; (i.e. no-backtrace doesn't take a value).
- (let loop ((in args) (out '()))
- (syntax-case in ()
- (() (reverse! out))
- ;; The user wanted #:foo, but wrote :foo. Fix it.
- ((sym . in) (keyword-like? #'sym)
- (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
- ((kw . in) (not (keyword? (syntax->datum #'kw)))
- (syntax-violation 'define-module "expected keyword arg" x #'kw))
- ((#:no-backtrace . in)
- (loop #'in (cons #:no-backtrace out)))
- ((#:pure . in)
- (loop #'in (cons #:pure out)))
- ((kw)
- (syntax-violation 'define-module "keyword arg without value" x #'kw))
- ((use-module (name name* ...) . in)
- (and (memq (syntax->datum #'use-module) '(#:use-module #:use-syntax))
- (and-map symbol? (syntax->datum #'(name name* ...))))
- (loop #'in
- (cons* #''((name name* ...))
- #'use-module
- out)))
- ((use-module ((name name* ...) arg ...) . in)
- (and (memq (syntax->datum #'use-module) '(#:use-module #:use-syntax))
- (and-map symbol? (syntax->datum #'(name name* ...))))
- (loop #'in
- (cons* #`(list '(name name* ...) #,@(quotify-iface #'(arg ...)))
- #'use-module
- out)))
- ((#:autoload name bindings . in)
- (loop #'in (cons* #''bindings #''name #:autoload out)))
- ((kw val . in)
- (loop #'in (cons* #''val #'kw out))))))
+ (syntax-case args ()
+ (()
+ (let ((imp (if (null? imp) '() #`(#:imports `#,imp)))
+ (exp (if (null? exp) '() #`(#:exports '#,exp)))
+ (rex (if (null? rex) '() #`(#:re-exports '#,rex)))
+ (rep (if (null? rep) '() #`(#:replacements '#,rep)))
+ (aut (if (null? aut) '() #`(#:autoloads '#,aut))))
+ #`(#,@imp #,@exp #,@rex #,@rep #,@aut)))
+ ;; The user wanted #:foo, but wrote :foo. Fix it.
+ ((sym . args) (keyword-like? #'sym)
+ (parse #`(#,(->keyword (syntax->datum #'sym)) . args)
+ imp exp rex rep aut))
+ ((kw . args) (not (keyword? (syntax->datum #'kw)))
+ (syntax-violation 'define-module "expected keyword arg" x #'kw))
+ ((#:no-backtrace . args)
+ ;; Ignore this one.
+ (parse #'args imp exp rex rep aut))
+ ((#:pure . args)
+ #`(#:pure #t . #,(parse #'args imp exp rex rep aut)))
+ ((kw)
+ (syntax-violation 'define-module "keyword arg without value" x #'kw))
+ ((#:version (v ...) . args)
+ #`(#:version '(v ...) . #,(parse #'args imp exp rex rep aut)))
+ ((#:duplicates (d ...) . args)
+ #`(#:duplicates '(d ...) . #,(parse #'args imp exp rex rep aut)))
+ ((#:filename f . args)
+ #`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
+ ((#:use-module (name name* ...) . args)
+ (and (and-map symbol? (syntax->datum #'(name name* ...))))
+ (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 #`(#,@imp ((name name* ...))) exp rex rep aut)))
+ ((#:use-module ((name name* ...) arg ...) . args)
+ (and (and-map symbol? (syntax->datum #'(name name* ...))))
+ (parse #'args
+ #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
+ exp rex rep aut))
+ ((#:export (ex ...) . args)
+ (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+ ((#:export-syntax (ex ...) . args)
+ (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+ ((#:re-export (re ...) . args)
+ (parse #'args imp exp #`(#,@rex re ...) rep aut))
+ ((#:re-export-syntax (re ...) . args)
+ (parse #'args imp exp #`(#,@rex re ...) rep aut))
+ ((#:replace (r ...) . args)
+ (parse #'args imp exp rex #`(#,@rep r ...) aut))
+ ((#:replace-syntax (r ...) . args)
+ (parse #'args imp exp rex #`(#,@rep r ...) aut))
+ ((#:autoload name bindings . args)
+ (parse #'args imp exp rex rep #`(#,@aut name bindings)))
+ ((kw val . args)
+ (syntax-violation 'define-module "unknown keyword or bad argument"
+ #'kw #'val))))
(syntax-case x ()
((_ (name name* ...) arg ...)
- (with-syntax (((quoted-arg ...) (quotify #'(arg ...))))
+ (and-map symbol? (syntax->datum #'(name name* ...)))
+ (with-syntax (((quoted-arg ...)
+ (parse #'(arg ...) '() '() '() '() '()))
+ ;; Ideally the filename is either a string or #f;
+ ;; this hack is to work around a case in which
+ ;; port-filename returns a symbol (`socket') for
+ ;; sockets.
+ (filename (let ((f (assq-ref (or (syntax-source x) '())
+ 'filename)))
+ (and (string? f) f))))
#'(eval-when (eval load compile expand)
- (let ((m (process-define-module
- (list '(name name* ...)
- #:filename (assq-ref
- (or (current-source-location) '())
- 'filename)
- quoted-arg ...))))
+ (let ((m (define-module* '(name name* ...)
+ #:filename filename quoted-arg ...)))
(set-current-module m)
m)))))))
(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 ...)))))
+(define-syntax-rule (use-syntax 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 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 (export name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-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 (re-export name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-re-export! (current-module) '(name ...))))))
-(define-syntax export-syntax
- (syntax-rules ()
- ((_ name ...)
- (export name ...))))
+(define-syntax-rule (export! name ...)
+ (eval-when (eval load compile expand)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-replace! (current-module) '(name ...))))))
-(define-syntax re-export-syntax
- (syntax-rules ()
- ((_ name ...)
- (re-export name ...))))
+(define-syntax-rule (export-syntax name ...)
+ (export name ...))
-(define load load-module)
+(define-syntax-rule (re-export-syntax name ...)
+ (re-export name ...))
\f
;;; {Parameters}
;;;
-(define make-mutable-parameter
- (let ((make (lambda (fluid converter)
- (lambda args
- (if (null? args)
- (fluid-ref fluid)
- (fluid-set! fluid (converter (car args))))))))
- (lambda* (init #:optional (converter identity))
- (let ((fluid (make-fluid)))
- (fluid-set! fluid (converter init))
- (make fluid converter)))))
+(define* (make-mutable-parameter init #:optional (converter identity))
+ (let ((fluid (make-fluid (converter init))))
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((val) (fluid-set! fluid (converter val))))))
+
\f
#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)
\f
+;;; {`load'.}
+;;;
+;;; Load is tricky when combined with relative paths, compilation, and
+;;; 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.
+;;;
+;;; To get around all of this, we're going to do something nasty, and
+;;; turn `load' into a macro. That way it can know the path of the
+;;; source file with respect to which it was invoked, so it can resolve
+;;; relative paths with respect to the original source path.
+;;;
+;;; There is an exception, and that is that if the source file was in
+;;; the load path when it was compiled, instead of looking up against
+;;; the absolute source location, we load-from-path against the relative
+;;; source location.
+;;;
+
+(define %auto-compilation-options
+ ;; Default `compile-file' option when auto-compiling.
+ '(#: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
+ ;; as primitive-load-path does internally. primitive-load is
+ ;; unaffected. Returns #f if auto-compilation failed or was disabled.
+ ;;
+ ;; NB: Unless we need to compile the file, this function should not cause
+ ;; (system base compile) to be loaded up. For that reason compiled-file-name
+ ;; 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
+ (canonical->suffix canon-path)
+ (cond ((or (null? %load-compiled-extensions)
+ (string-null? (car %load-compiled-extensions)))
+ (warn "invalid %load-compiled-extensions"
+ %load-compiled-extensions)
+ ".go")
+ (else (car %load-compiled-extensions))))))
+
+ (define (fresh-compiled-file-name name go-path)
+ (catch #t
+ (lambda ()
+ (let* ((scmstat (stat name))
+ (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))
+ (>= (stat:mtimensec gostat)
+ (stat:mtimensec scmstat)))))
+ go-path
+ (begin
+ (if gostat
+ (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-warning-port) ";;; compiling ~a\n" name)
+ (let ((cfn
+ ((module-ref
+ (resolve-interface '(system base compile))
+ 'compile-file)
+ name
+ #:opts %auto-compilation-options
+ #:env (current-module))))
+ (format (current-warning-port) ";;; compiled ~a\n" cfn)
+ cfn))
+ (else #f))))))
+ (lambda (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)
+ (string-prefix? "/" path))
+
+ (define (load-absolute abs-path)
+ (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path))))
+ (and canon
+ (let ((go-path (compiled-file-name canon)))
+ (and go-path
+ (fresh-compiled-file-name abs-path go-path)))))))
+ (if cfn
+ (begin
+ (if %load-hook
+ (%load-hook abs-path))
+ (load-compiled cfn))
+ (start-stack 'load-stack
+ (primitive-load abs-path)))))
+
+ (save-module-excursion
+ (lambda ()
+ (with-fluids ((current-reader reader)
+ (%file-port-name-canonicalization 'relative))
+ (cond
+ ((or (absolute-path? path))
+ (load-absolute path))
+ ((absolute-path? dir)
+ (load-absolute (in-vicinity dir path)))
+ (else
+ (load-from-path (in-vicinity dir path))))))))
+
+(define-syntax load
+ (make-variable-transformer
+ (lambda (x)
+ (let* ((src (syntax-source x))
+ (file (and src (assq-ref src 'filename)))
+ (dir (and (string? file) (dirname file))))
+ (syntax-case x ()
+ ((_ arg ...)
+ #`(load-in-vicinity #,(or dir #'(getcwd)) arg ...))
+ (id
+ (identifier? #'id)
+ #`(lambda args
+ (apply load-in-vicinity #,(or dir #'(getcwd)) args))))))))
+
+\f
+
;;; {`cond-expand' for SRFI-0 support.}
;;;
;;; This syntactic form expands into different commands or
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
))
(append (hashq-ref %cond-expand-table mod '())
features)))))
-(define-macro (cond-expand . clauses)
- (let ((syntax-error (lambda (cl)
- (error "invalid clause in `cond-expand'" cl))))
- (letrec
- ((test-clause
- (lambda (clause)
- (cond
- ((symbol? clause)
- (or (memq clause %cond-expand-features)
- (let lp ((uses (module-uses (current-module))))
- (if (pair? uses)
- (or (memq clause
- (hashq-ref %cond-expand-table
- (car uses) '()))
- (lp (cdr uses)))
- #f))))
- ((pair? clause)
- (cond
- ((eq? 'and (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #t)
- ((pair? l)
- (and (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'or (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #f)
- ((pair? l)
- (or (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'not (car clause))
- (cond ((not (pair? (cdr clause)))
- (syntax-error clause))
- ((pair? (cddr clause))
- ((syntax-error clause))))
- (not (test-clause (cadr clause))))
- (else
- (syntax-error clause))))
- (else
- (syntax-error clause))))))
- (let lp ((c clauses))
- (cond
- ((null? c)
- (error "Unfulfilled `cond-expand'"))
- ((not (pair? c))
- (syntax-error c))
- ((not (pair? (car c)))
- (syntax-error (car c)))
- ((test-clause (caar c))
- `(begin ,@(cdar c)))
- ((eq? (caar c) 'else)
- (if (pair? (cdr c))
- (syntax-error c))
- `(begin ,@(cdar c)))
- (else
- (lp (cdr c))))))))
+(define-syntax cond-expand
+ (lambda (x)
+ (define (module-has-feature? mod sym)
+ (or-map (lambda (mod)
+ (memq sym (hashq-ref %cond-expand-table mod '())))
+ (module-uses mod)))
+
+ (define (condition-matches? condition)
+ (syntax-case condition (and or not)
+ ((and c ...)
+ (and-map condition-matches? #'(c ...)))
+ ((or c ...)
+ (or-map condition-matches? #'(c ...)))
+ ((not c)
+ (if (condition-matches? #'c) #f #t))
+ (c
+ (identifier? #'c)
+ (let ((sym (syntax->datum #'c)))
+ (if (memq sym %cond-expand-features)
+ #t
+ (module-has-feature? (current-module) sym))))))
+
+ (define (match clauses alternate)
+ (syntax-case clauses ()
+ (((condition form ...) . rest)
+ (if (condition-matches? #'condition)
+ #'(begin form ...)
+ (match #'rest alternate)))
+ (() (alternate))))
+
+ (syntax-case x (else)
+ ((_ clause ... (else form ...))
+ (match #'(clause ...)
+ (lambda ()
+ #'(begin form ...))))
+ ((_ clause ...)
+ (match #'(clause ...)
+ (lambda ()
+ (syntax-violation 'cond-expand "unfulfilled cond-expand" x)))))))
;; This procedure gets called from the startup code with a list of
;; numbers, which are the numbers of the SRFIs to be loaded on startup.
;;; 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)))))
+(define-syntax require-extension
+ (lambda (x)
+ (syntax-case x (srfi)
+ ((_ (srfi n ...))
+ (and-map integer? (syntax->datum #'(n ...)))
+ (with-syntax
+ (((srfi-n ...)
+ (map (lambda (n)
+ (datum->syntax x (symbol-append 'srfi- n)))
+ (map string->symbol
+ (map number->string (syntax->datum #'(n ...)))))))
+ #'(use-modules (srfi srfi-n) ...)))
+ ((_ (type arg ...))
+ (identifier? #'type)
+ (syntax-violation 'require-extension "Not a recognized extension type"
+ x)))))
\f
-
-;;; {Load emacs interface support if emacs option is given.}
+;;; Defining transparently inlinable procedures
;;;
-(define (named-module-use! user usee)
- (module-use! (resolve-module user) (resolve-interface usee)))
+(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)))
-(define (load-emacs-interface)
- (and (provided? 'debug-extensions)
- (debug-enable 'backtrace))
- (named-module-use! '(guile-user) '(ice-9 emacs)))
+ (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 ...)
+ (fluid-let-syntax ((name (identifier-syntax proc-name)))
+ body ...))
+ (define-syntax name
+ (lambda (x)
+ (syntax-case x ()
+ ((_ args ...)
+ #'((fluid-let-syntax ((name (identifier-syntax proc-name)))
+ (lambda (formals ...)
+ body ...))
+ args ...))
+ (_
+ (identifier? x)
+ #'proc-name))))))))))
\f
(lambda () (fluid-ref using-readline?))
(lambda (v) (fluid-set! using-readline? v)))))
-(define (top-repl)
- (let ((guile-user-module (resolve-module '(guile-user))))
-
- ;; Load emacs interface support if emacs option is given.
- (if (and (module-defined? guile-user-module 'use-emacs-interface)
- (module-ref guile-user-module 'use-emacs-interface))
- (load-emacs-interface))
-
- ;; Use some convenient modules (in reverse order)
-
- (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-autoload! guile-user-module '(system vm debug) '(debug))
-
- ;; 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)
- ;; We can't use @ here, as modules have been booted, but in Guile's
- ;; build the srfi-1 helper lib hasn't been built yet, which will
- ;; result in an error when (system repl repl) is loaded at compile
- ;; time (to see if it is a macro or not).
- (start-repl (module-ref (resolve-module '(system repl repl))
- 'start-repl))
- (signals (if (provided? 'posix)
- `((,SIGINT . "User interrupt")
- (,SIGFPE . "Arithmetic 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
-
- ;; call at entry
- (lambda ()
- (let ((make-handler (lambda (msg)
- (lambda (sig)
- (scm-error 'signal
- #f
- msg
- #f
- (list sig))))))
- (set! old-handlers
- (map (lambda (sig-msg)
- (sigaction (car sig-msg)
- (make-handler (cdr sig-msg))))
- signals))))
-
- ;; the protected thunk.
- (lambda ()
- (let ((status (start-repl 'scheme)))
- (run-hook exit-hook)
- status))
-
- ;; call at exit.
- (lambda ()
- (map (lambda (sig-msg old-handler)
- (if (not (car old-handler))
- ;; restore original C handler.
- (sigaction (car sig-msg) #f)
- ;; restore Scheme handler, SIG_IGN or SIG_DFL.
- (sigaction (car sig-msg)
- (car old-handler)
- (cdr old-handler))))
- signals old-handlers))))))
-
-;;; This hook is run at the very end of an interactive session.
-;;;
-(define exit-hook (make-hook))
-
\f
;;; {Deprecated stuff}
;; FIXME:
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
+;; Set filename to #f to prevent reload.
(define-module (guile-user)
- #:autoload (system base compile) (compile))
+ #:autoload (system base compile) (compile compile-file)
+ #:filename #f)
;; Remain in the `(guile)' module at compilation-time so that the
;; `-Wunused-toplevel' warning works as expected.
HCoop / bpt / guile.git / blobdiff