X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/b38507c1af6a74373c208ff3effc85dc3988a8ea..c5f30c4cba204114008b8ddc8ecea5a081be69b7:/module/ice-9/boot-9.scm diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 2a24a87ca..f706a716b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010 +;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011 ;;;; Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -67,6 +67,7 @@ ;; Define catch and with-throw-handler, using some common helper routines and a ;; shared fluid. Hide the helpers in a lexical contour. +(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 @@ -118,9 +119,9 @@ (apply prev thrown-k args)))) (apply prev thrown-k args))))) - (define! 'catch - (lambda* (k thunk handler #:optional pre-unwind-handler) - "Invoke @var{thunk} in the dynamic context of @var{handler} for + (set! catch + (lambda* (k thunk handler #:optional pre-unwind-handler) + "Invoke @var{thunk} in the dynamic context of @var{handler} for exceptions matching @var{key}. If thunk throws to the symbol @var{key}, then @var{handler} is invoked this way: @lisp @@ -153,47 +154,47 @@ A @var{pre-unwind-handler} can exit either normally or non-locally. If it exits normally, Guile unwinds the stack and dynamic context 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 - "Wrong type argument in position ~a: ~a" - (list 1 k) (list k))) - (let ((tag (make-prompt-tag "catch"))) - (call-with-prompt - tag - (lambda () - (with-fluids - ((%exception-handler - (if pre-unwind-handler - (custom-throw-handler tag k pre-unwind-handler) - (default-throw-handler tag k)))) - (thunk))) - (lambda (cont k . args) - (apply handler k args)))))) - - (define! 'with-throw-handler - (lambda (k thunk pre-unwind-handler) - "Add @var{handler} to the dynamic context as a throw handler + (if (not (or (symbol? k) (eqv? k #t))) + (scm-error "catch" 'wrong-type-arg + "Wrong type argument in position ~a: ~a" + (list 1 k) (list k))) + (let ((tag (make-prompt-tag "catch"))) + (call-with-prompt + tag + (lambda () + (with-fluids + ((%exception-handler + (if pre-unwind-handler + (custom-throw-handler tag k pre-unwind-handler) + (default-throw-handler tag k)))) + (thunk))) + (lambda (cont k . args) + (apply handler k args)))))) + + (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}." - (if (not (or (symbol? k) (eqv? k #t))) - (scm-error "with-throw-handler" 'wrong-type-arg - "Wrong type argument in position ~a: ~a" - (list 1 k) (list k))) - (with-fluids ((%exception-handler - (custom-throw-handler #f k pre-unwind-handler))) - (thunk)))) - - (define! 'throw - (lambda (key . args) - "Invoke the catch form matching @var{key}, passing @var{args} to the + (if (not (or (symbol? k) (eqv? k #t))) + (scm-error "with-throw-handler" 'wrong-type-arg + "Wrong type argument in position ~a: ~a" + (list 1 k) (list k))) + (with-fluids ((%exception-handler + (custom-throw-handler #f k pre-unwind-handler))) + (thunk)))) + + (set! throw + (lambda (key . args) + "Invoke the catch form matching @var{key}, passing @var{args} to the @var{handler}. @var{key} is a symbol. It will match catches of the same symbol or of @code{#t}. If there is no handler at all, Guile prints an error and then exits." - (if (not (symbol? key)) - ((exception-handler) 'wrong-type-arg "throw" - "Wrong type argument in position ~a: ~a" (list 1 key) (list key)) - (apply (exception-handler) key args))))) + (if (not (symbol? key)) + ((exception-handler) 'wrong-type-arg "throw" + "Wrong type argument in position ~a: ~a" (list 1 key) (list key)) + (apply (exception-handler) key args))))) @@ -254,6 +255,14 @@ If there is no handler at all, Guile prints an error and then exits." +;;; {Structs} +;;; + +(define (make-struct/no-tail vtable . args) + (apply make-struct vtable 0 args)) + + + ;;; {and-map and or-map} ;;; ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) @@ -325,12 +334,13 @@ If there is no handler at all, Guile prints an error and then exits." ;; 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))))) @@ -463,6 +473,11 @@ If there is no handler at all, Guile prints an error and then exits." (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))))) @@ -507,13 +522,14 @@ If there is no handler at all, Guile prints an error and then exits." ;;; {Deprecation} ;;; -;;; Depends on: defmacro -;;; -(defmacro begin-deprecated forms - (if (include-deprecated-features) - `(begin ,@forms) - `(begin))) +(define-syntax begin-deprecated + (lambda (x) + (syntax-case x () + ((_ form form* ...) + (if (include-deprecated-features) + #'(begin form form* ...) + #'(begin)))))) @@ -521,16 +537,38 @@ If there is no handler at all, Guile prints an error and then exits." ;;; (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) -(defmacro false-if-exception (expr) - `(catch #t - (lambda () - ;; avoid saving backtraces inside false-if-exception - (with-fluids ((the-last-stack (fluid-ref the-last-stack))) - ,expr)) - (lambda args #f))) +(define-syntax false-if-exception + (syntax-rules () + ((_ expr) + (catch #t + (lambda () expr) + (lambda (k . args) #f))))) @@ -848,10 +886,8 @@ If there is no handler at all, Guile prints an error and then exits." (define error (case-lambda (() - (save-stack) (scm-error 'misc-error #f "?" #f #f)) ((message . args) - (save-stack) (let ((msg (string-join (cons "~A" (make-list (length args) "~S"))))) (scm-error 'misc-error #f msg (cons message args) #f))))) @@ -995,10 +1031,6 @@ If there is no handler at all, Guile prints an error and then exits." ;;; {Load Paths} ;;; -;;; Here for backward compatability -;; -(define scheme-file-suffix (lambda () ".scm")) - (define (in-vicinity vicinity file) (let ((tail (let ((len (string-length vicinity))) (if (zero? len) @@ -1025,11 +1057,6 @@ If there is no handler at all, Guile prints an error and then exits." ;; 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)))) @@ -1053,7 +1080,7 @@ If there is no handler at all, Guile prints an error and then exits." (or (fluid-ref %stacks) '())))) (thunk))) (lambda (k . args) - (%start-stack tag (lambda () (apply k args))))))) + (%start-stack tag (lambda () (apply k args))))))) (define-syntax start-stack (syntax-rules () ((_ tag exp) @@ -1112,8 +1139,12 @@ If there is no handler at all, Guile prints an error and then exits." (catch #t (lambda () (let* ((scmstat (stat name)) - (gostat (stat go-path #f))) - (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat))) + (gostat (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 @@ -1165,130 +1196,6 @@ If there is no handler at all, Guile prints an error and then exits." -;;; {Command Line Options} -;;; - -(define (get-option argv kw-opts kw-args return) - (cond - ((null? argv) - (return #f #f argv)) - - ((or (not (eq? #\- (string-ref (car argv) 0))) - (eq? (string-length (car argv)) 1)) - (return 'normal-arg (car argv) (cdr argv))) - - ((eq? #\- (string-ref (car argv) 1)) - (let* ((kw-arg-pos (or (string-index (car argv) #\=) - (string-length (car argv)))) - (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos))) - (kw-opt? (member kw kw-opts)) - (kw-arg? (member kw kw-args)) - (arg (or (and (not (eq? kw-arg-pos (string-length (car argv)))) - (substring (car argv) - (+ kw-arg-pos 1) - (string-length (car argv)))) - (and kw-arg? - (begin (set! argv (cdr argv)) (car argv)))))) - (if (or kw-opt? kw-arg?) - (return kw arg (cdr argv)) - (return 'usage-error kw (cdr argv))))) - - (else - (let* ((char (substring (car argv) 1 2)) - (kw (symbol->keyword char))) - (cond - - ((member kw kw-opts) - (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) - (new-argv (if (= 0 (string-length rest-car)) - (cdr argv) - (cons (string-append "-" rest-car) (cdr argv))))) - (return kw #f new-argv))) - - ((member kw kw-args) - (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) - (arg (if (= 0 (string-length rest-car)) - (cadr argv) - rest-car)) - (new-argv (if (= 0 (string-length rest-car)) - (cddr argv) - (cdr argv)))) - (return kw arg new-argv))) - - (else (return 'usage-error kw argv))))))) - -(define (for-next-option proc argv kw-opts kw-args) - (let loop ((argv argv)) - (get-option argv kw-opts kw-args - (lambda (opt opt-arg argv) - (and opt (proc opt opt-arg argv loop)))))) - -(define (display-usage-report kw-desc) - (for-each - (lambda (kw) - (or (eq? (car kw) #t) - (eq? (car kw) 'else) - (let* ((opt-desc kw) - (help (cadr opt-desc)) - (opts (car opt-desc)) - (opts-proper (if (string? (car opts)) (cdr opts) opts)) - (arg-name (if (string? (car opts)) - (string-append "<" (car opts) ">") - "")) - (left-part (string-append - (with-output-to-string - (lambda () - (map (lambda (x) (display (keyword->symbol x)) (display " ")) - opts-proper))) - arg-name)) - (middle-part (if (and (< (string-length left-part) 30) - (< (string-length help) 40)) - (make-string (- 30 (string-length left-part)) #\ ) - "\n\t"))) - (display left-part) - (display middle-part) - (display help) - (newline)))) - kw-desc)) - - - -(define (transform-usage-lambda cases) - (let* ((raw-usage (delq! 'else (map car cases))) - (usage-sans-specials (map (lambda (x) - (or (and (not (list? x)) x) - (and (symbol? (car x)) #t) - (and (boolean? (car x)) #t) - x)) - raw-usage)) - (usage-desc (delq! #t usage-sans-specials)) - (kw-desc (map car usage-desc)) - (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc))) - (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc))) - (transmogrified-cases (map (lambda (case) - (cons (let ((opts (car case))) - (if (or (boolean? opts) (eq? 'else opts)) - opts - (cond - ((symbol? (car opts)) opts) - ((boolean? (car opts)) opts) - ((string? (caar opts)) (cdar opts)) - (else (car opts))))) - (cdr case))) - cases))) - `(let ((%display-usage (lambda () (display-usage-report ',usage-desc)))) - (lambda (%argv) - (let %next-arg ((%argv %argv)) - (get-option %argv - ',kw-opts - ',kw-args - (lambda (%opt %arg %new-argv) - (case %opt - ,@ transmogrified-cases)))))))) - - - - ;;; {Low Level Modules} ;;; ;;; These are the low level data structures for modules. @@ -1582,48 +1489,34 @@ If there is no handler at all, Guile prints an error and then exits." ;; 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)) +(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)) - (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)) @@ -1938,36 +1831,32 @@ If there is no handler at all, Guile prints an error and then exits." (define (module-define-submodule! module name submodule) (hashq-set! (module-submodules module) name submodule)) - - -;;; {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))) @@ -2081,10 +1970,16 @@ If there is no handler at all, Guile prints an error and then exits." ;; Same as MODULE-USE! but add multiple interfaces and check for duplicates ;; (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 ((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)) + (hash-clear! (module-import-obarray module)) + (module-modified module))) @@ -2203,12 +2098,23 @@ If there is no handler at all, Guile prints an error and then exits." (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)) @@ -2224,15 +2130,34 @@ If there is no handler at all, Guile prints an error and then exits." (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) + m)) + +(set-module-public-interface! the-root-module the-scm-module) @@ -2247,7 +2172,7 @@ If there is no handler at all, Guile prints an error and then exits." ;; 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) @@ -2297,103 +2222,32 @@ If there is no handler at all, Guile prints an error and then exits." (module-use! module the-scm-module))) (define (version-matches? version-ref target) - (define (any pred lst) - (and (not (null? lst)) (or (pred (car lst)) (any pred (cdr lst))))) - (define (every pred lst) - (or (null? lst) (and (pred (car lst)) (every pred (cdr lst))))) (define (sub-versions-match? v-refs t) (define (sub-version-matches? v-ref t) - (define (curried-sub-version-matches? v) - (sub-version-matches? v t)) - (cond ((number? v-ref) (eqv? v-ref t)) - ((list? v-ref) - (let ((cv (car v-ref))) - (cond ((eq? cv '>=) (>= t (cadr v-ref))) - ((eq? cv '<=) (<= t (cadr v-ref))) - ((eq? cv 'and) - (every curried-sub-version-matches? (cdr v-ref))) - ((eq? cv 'or) - (any curried-sub-version-matches? (cdr v-ref))) - ((eq? cv 'not) (not (sub-version-matches? (cadr v-ref) t))) - (else (error "Incompatible sub-version reference" cv))))) - (else (error "Incompatible sub-version reference" v-ref)))) + (let ((matches? (lambda (v) (sub-version-matches? v t)))) + (cond + ((number? v-ref) (eqv? v-ref t)) + ((list? v-ref) + (case (car v-ref) + ((>=) (>= t (cadr v-ref))) + ((<=) (<= t (cadr v-ref))) + ((and) (and-map matches? (cdr v-ref))) + ((or) (or-map matches? (cdr v-ref))) + ((not) (not (matches? (cadr v-ref)))) + (else (error "Invalid sub-version reference" v-ref)))) + (else (error "Invalid sub-version reference" v-ref))))) (or (null? v-refs) (and (not (null? t)) (sub-version-matches? (car v-refs) (car t)) (sub-versions-match? (cdr v-refs) (cdr t))))) - (define (curried-version-matches? v) - (version-matches? v target)) - (or (null? version-ref) - (let ((cv (car version-ref))) - (cond ((eq? cv 'and) (every curried-version-matches? (cdr version-ref))) - ((eq? cv 'or) (any curried-version-matches? (cdr version-ref))) - ((eq? cv 'not) (not (version-matches? (cadr version-ref) target))) - (else (sub-versions-match? version-ref target)))))) - -(define (find-versioned-module dir-hint name version-ref roots) - (define (subdir-pair-less pair1 pair2) - (define (numlist-less lst1 lst2) - (or (null? lst2) - (and (not (null? lst1)) - (cond ((> (car lst1) (car lst2)) #t) - ((< (car lst1) (car lst2)) #f) - (else (numlist-less (cdr lst1) (cdr lst2))))))) - (not (numlist-less (car pair2) (car pair1)))) - (define (match-version-and-file pair) - (and (version-matches? version-ref (car pair)) - (let ((filenames - (filter (lambda (file) - (let ((s (false-if-exception (stat file)))) - (and s (eq? (stat:type s) 'regular)))) - (map (lambda (ext) - (string-append (cdr pair) name ext)) - %load-extensions)))) - (and (not (null? filenames)) - (cons (car pair) (car filenames)))))) - - (define (match-version-recursive root-pairs leaf-pairs) - (define (filter-subdirs root-pairs ret) - (define (filter-subdir root-pair dstrm subdir-pairs) - (let ((entry (readdir dstrm))) - (if (eof-object? entry) - subdir-pairs - (let* ((subdir (string-append (cdr root-pair) entry)) - (num (string->number entry)) - (num (and num (exact? num) (append (car root-pair) - (list num))))) - (if (and num (eq? (stat:type (stat subdir)) 'directory)) - (filter-subdir - root-pair dstrm (cons (cons num (string-append subdir "/")) - subdir-pairs)) - (filter-subdir root-pair dstrm subdir-pairs)))))) - - (or (and (null? root-pairs) ret) - (let* ((rp (car root-pairs)) - (dstrm (false-if-exception (opendir (cdr rp))))) - (if dstrm - (let ((subdir-pairs (filter-subdir rp dstrm '()))) - (closedir dstrm) - (filter-subdirs (cdr root-pairs) - (or (and (null? subdir-pairs) ret) - (append ret subdir-pairs)))) - (filter-subdirs (cdr root-pairs) ret))))) - - (or (and (null? root-pairs) leaf-pairs) - (let ((matching-subdir-pairs (filter-subdirs root-pairs '()))) - (match-version-recursive - matching-subdir-pairs - (append leaf-pairs (filter pair? (map match-version-and-file - matching-subdir-pairs))))))) - (define (make-root-pair root) - (cons '() (string-append root "/" dir-hint))) - - (let* ((root-pairs (map make-root-pair roots)) - (matches (if (null? version-ref) - (filter pair? (map match-version-and-file root-pairs)) - '())) - (matches (append matches (match-version-recursive root-pairs '())))) - (and (null? matches) (error "No matching modules found.")) - (cdar (sort matches subdir-pair-less)))) + + (let ((matches? (lambda (v) (version-matches? v target)))) + (or (null? version-ref) + (case (car version-ref) + ((and) (and-map matches? (cdr version-ref))) + ((or) (or-map matches? (cdr version-ref))) + ((not) (not (matches? (cadr version-ref)))) + (else (sub-versions-match? version-ref target)))))) (define (make-fresh-user-module) (let ((m (make-module))) @@ -2414,7 +2268,7 @@ If there is no handler at all, Guile prints an error and then exits." ((and already (or (not autoload) (module-public-interface already))) ;; A hit, a palpable hit. - (if (and version + (if (and version (not (version-matches? version (module-version already)))) (error "incompatible module version already loaded" name)) already) @@ -2433,6 +2287,19 @@ If there is no handler at all, Guile prints an error and then exits." (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))) @@ -2482,7 +2349,7 @@ If there is no handler at all, Guile prints an error and then exits." (symbol-prefix-proc prefix) identity)) version) - (let* ((module (resolve-module name #t version)) + (let* ((module (resolve-module name #t version #:ensure #f)) (public-i (and module (module-public-interface module)))) (and (or (not module) (not public-i)) (error "no code for module" name)) @@ -2529,135 +2396,78 @@ If there is no handler at all, Guile prints an error and then exits." ;; 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))) + (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 () + (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))))) + + (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)) @@ -2732,10 +2542,16 @@ module '(ice-9 q) '(make-q q-length))}." (with-fluids ((current-reader #f)) (save-module-excursion (lambda () - (if version - (load (find-versioned-module - dir-hint name version %load-path)) - (primitive-load-path (in-vicinity dir-hint name) #f)) + ;; The initial environment when loading a module is a fresh + ;; user module. + (set-current-module (make-fresh-user-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, + ;; etc. Punt for now, and don't use versions when locating + ;; the file. + (primitive-load-path (in-vicinity dir-hint name) #f) (set! didit #t))))) (lambda () (set-autoloaded! dir-hint name didit))) didit)))) @@ -2777,74 +2593,49 @@ module '(ice-9 q) '(make-q q-length))}." ;;; {Run-time options} ;;; -(defmacro define-option-interface (option-group) - (let* ((option-name 'car) - (option-value 'cadr) - (option-documentation 'caddr) - - ;; Below follow the macros defining the run-time option interfaces. - - (make-options (lambda (interface) - `(lambda args - (cond ((null? args) (,interface)) - ((list? (car args)) - (,interface (car args)) (,interface)) - (else (for-each - (lambda (option) - (display (,option-name option)) - (if (< (string-length - (symbol->string (,option-name option))) - 8) - (display #\tab)) - (display #\tab) - (display (,option-value option)) - (display #\tab) - (display (,option-documentation option)) - (newline)) - (,interface #t))))))) - - (make-enable (lambda (interface) - `(lambda flags - (,interface (append flags (,interface))) - (,interface)))) - - (make-disable (lambda (interface) - `(lambda flags - (let ((options (,interface))) - (for-each (lambda (flag) - (set! options (delq! flag options))) - flags) - (,interface options) - (,interface)))))) - (let* ((interface (car option-group)) - (options/enable/disable (cadr option-group))) - `(begin - (define ,(car options/enable/disable) - ,(make-options interface)) - (define ,(cadr options/enable/disable) - ,(make-enable interface)) - (define ,(caddr options/enable/disable) - ,(make-disable interface)) - (defmacro ,(caaddr option-group) (opt val) - `(,',(car options/enable/disable) - (append (,',(car options/enable/disable)) - (list ',opt ,val)))))))) - -(define-option-interface - (eval-options-interface - (eval-options eval-enable eval-disable) - (eval-set!))) +(define-syntax define-option-interface + (syntax-rules () + ((_ (interface (options enable disable) (option-set!))) + (begin + (define options + (case-lambda + (() (interface)) + ((arg) + (if (list? arg) + (begin (interface arg) (interface)) + (for-each + (lambda (option) + (apply (lambda (name value documentation) + (display name) + (if (< (string-length (symbol->string name)) 8) + (display #\tab)) + (display #\tab) + (display value) + (display #\tab) + (display documentation) + (newline)) + option)) + (interface #t)))))) + (define (enable . flags) + (interface (append flags (interface))) + (interface)) + (define (disable . flags) + (let ((options (interface))) + (for-each (lambda (flag) (set! options (delq! flag options))) + 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-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) @@ -2857,97 +2648,39 @@ module '(ice-9 q) '(make-q q-length))}." -;;; {Running Repls} +;;; {The Unspecified Value} +;;; +;;; Currently Guile represents unspecified values via one particular value, +;;; which may be obtained by evaluating (if #f #f). It would be nice in the +;;; future if we could replace this with a return of 0 values, though. ;;; -(define (repl read evaler print) - (let loop ((source (read (current-input-port)))) - (print (evaler source)) - (loop (read (current-input-port))))) - -;; A provisional repl that acts like the SCM repl: -;; -(define scm-repl-silent #f) -(define (assert-repl-silence v) (set! scm-repl-silent v)) +(define-syntax *unspecified* + (identifier-syntax (if #f #f))) -(define *unspecified* (if #f #f)) (define (unspecified? v) (eq? v *unspecified*)) -(define scm-repl-print-unspecified #f) -(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v)) - -(define scm-repl-verbose #f) -(define (assert-repl-verbosity v) (set! scm-repl-verbose v)) -(define scm-repl-prompt "guile> ") - -(define (set-repl-prompt! v) (set! scm-repl-prompt v)) - -(define (default-pre-unwind-handler key . args) - ;; Narrow by two more frames: this one, and the throw handler. - (save-stack 2) - (apply throw key args)) - -(begin-deprecated - (define (pre-unwind-handler-dispatch key . args) - (apply default-pre-unwind-handler key args))) - -(define abort-hook (make-hook)) - -;; these definitions are used if running a script. -;; otherwise redefined in error-catching-loop. -(define (set-batch-mode?! arg) #t) -(define (batch-mode?) #t) + -;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace () -(define before-signal-stack (make-fluid)) -;; FIXME: stack-saved? is broken in the presence of threads. -(define stack-saved? #f) +;;; {Running Repls} +;;; -(define (save-stack . narrowing) - (if (not stack-saved?) - (begin - (let ((stacks (fluid-ref %stacks))) - (fluid-set! the-last-stack - ;; (make-stack obj inner outer inner outer ...) - ;; - ;; In this case, cut away the make-stack frame, the - ;; save-stack frame, and then narrow as specified by the - ;; user, delimited by the nearest start-stack invocation, - ;; if any. - (apply make-stack #t - 2 - (if (pair? stacks) (cdar stacks) 0) - narrowing))) - (set! stack-saved? #t)))) +(define *repl-stack* (make-fluid)) -(define before-error-hook (make-hook)) -(define after-error-hook (make-hook)) -(define before-backtrace-hook (make-hook)) -(define after-backtrace-hook (make-hook)) +;; 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*) '()))) -(define has-shown-debugger-hint? #f) - -(define (handle-system-error key . args) - (let ((cep (current-error-port))) - (cond ((not (stack? (fluid-ref the-last-stack)))) - ((memq 'backtrace (debug-options-interface)) - (let ((highlights (if (or (eq? key 'wrong-type-arg) - (eq? key 'out-of-range)) - (list-ref args 3) - '()))) - (run-hook before-backtrace-hook) - (newline cep) - (display "Backtrace:\n") - (display-backtrace (fluid-ref the-last-stack) cep - #f #f highlights) - (newline cep) - (run-hook after-backtrace-hook)))) - (run-hook before-error-hook) - (apply display-error (fluid-ref the-last-stack) cep args) - (run-hook after-error-hook) - (force-output cep) - (throw 'abort key))) +;; 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 (ensure-batch-mode!) + (set! batch-mode? (lambda () #t))) (define (quit . args) (apply throw 'quit args)) @@ -2957,6 +2690,12 @@ module '(ice-9 q) '(make-q q-length))}." (define (gc-run-time) (cdr (assq 'gc-time-taken (gc-stats)))) +(define abort-hook (make-hook)) +(define before-error-hook (make-hook)) +(define after-error-hook (make-hook)) +(define before-backtrace-hook (make-hook)) +(define after-backtrace-hook (make-hook)) + (define before-read-hook (make-hook)) (define after-read-hook (make-hook)) (define before-eval-hook (make-hook 1)) @@ -2964,6 +2703,10 @@ module '(ice-9 q) '(make-q q-length))}." (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 @@ -2987,46 +2730,51 @@ module '(ice-9 q) '(make-q q-length))}." -;;; {collect} -;;; -;;; Similar to `begin' but returns a list of the results of all constituent -;;; forms instead of the result of the last form. -;;; (The definition relies on the current left-to-right -;;; order of evaluation of operands in applications.) -;;; - -(defmacro collect forms - (cons 'list forms)) - - - ;;; {While} ;;; ;;; with `continue' and `break'. ;;; -;; The inner `do' loop avoids re-establishing a catch every iteration, -;; that's only necessary if continue is actually used. A new key is -;; generated every time, so break and continue apply to their originating -;; `while' even when recursing. -;; -;; FIXME: This macro is unintentionally unhygienic with respect to let, -;; make-symbol, do, throw, catch, lambda, and not. +;; The inliner will remove the prompts at compile-time if it finds that +;; `continue' or `break' are not used. ;; -(define-macro (while cond . body) - (let ((keyvar (make-symbol "while-keyvar"))) - `(let ((,keyvar (make-symbol "while-key"))) - (do () - ((catch ,keyvar - (lambda () - (let ((break (lambda () (throw ,keyvar #t))) - (continue (lambda () (throw ,keyvar #f)))) - (do () - ((not ,cond)) - ,@body) - #t)) - (lambda (key arg) - arg))))))) +(define-syntax while + (lambda (x) + (syntax-case x () + ((while cond body ...) + #`(let ((break-tag (make-prompt-tag "break")) + (continue-tag (make-prompt-tag "continue"))) + (call-with-prompt + break-tag + (lambda () + (define-syntax #,(datum->syntax #'while 'break) + (lambda (x) + (syntax-case x () + ((_) + #'(abort-to-prompt break-tag)) + ((_ . args) + (syntax-violation 'break "too many arguments" x)) + (_ + #'(lambda () + (abort-to-prompt break-tag)))))) + (let lp () + (call-with-prompt + continue-tag + (lambda () + (define-syntax #,(datum->syntax #'while 'continue) + (lambda (x) + (syntax-case x () + ((_) + #'(abort-to-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 (k) (lp))))) + (lambda (k) + #t))))))) @@ -3037,16 +2785,13 @@ module '(ice-9 q) '(make-q q-length))}." ;; 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) @@ -3056,7 +2801,7 @@ module '(ice-9 q) '(make-q q-length))}." (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)) @@ -3066,59 +2811,88 @@ module '(ice-9 q) '(make-q q-length))}." ((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 (cons #'((name name* ...)) imp) 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))) + ((#:use-module ((name name* ...) arg ...) . args) + (and (and-map symbol? (syntax->datum #'(name name* ...)))) + (parse #'args + (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp) + 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))))))) @@ -3249,7 +3023,7 @@ module '(ice-9 q) '(make-q q-length))}." (define (fresh-interface!) (let ((iface (make-module))) (set-module-name! iface (module-name mod)) - ;; for guile 2: (set-module-version! iface (module-version mod)) + (set-module-version! iface (module-version mod)) (set-module-kind! iface 'interface) (set-module-public-interface! mod iface) iface)) @@ -3289,6 +3063,14 @@ module '(ice-9 q) '(make-q q-length))}." (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 export-syntax (syntax-rules () ((_ name ...) @@ -3306,16 +3088,13 @@ module '(ice-9 q) '(make-q q-length))}." ;;; {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))) + (fluid-set! fluid (converter init)) + (case-lambda + (() (fluid-ref fluid)) + ((val) (fluid-set! fluid (converter val)))))) + @@ -3487,66 +3266,45 @@ module '(ice-9 q) '(make-q q-length))}." (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. @@ -3563,48 +3321,22 @@ module '(ice-9 q) '(make-q q-length))}." ;;; 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))))) - - - -;;; {Load emacs interface support if emacs option is given.} -;;; - -(define (named-module-use! user usee) - (module-use! (resolve-module user) (resolve-interface usee))) - -(define (load-emacs-interface) - (and (provided? 'debug-extensions) - (debug-enable 'backtrace)) - (named-module-use! '(guile-user) '(ice-9 emacs))) +(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))))) @@ -3614,95 +3346,6 @@ module '(ice-9 q) '(make-q q-length))}." (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) - ;; Make a backup copy of the stack - (fluid-set! before-signal-stack - (fluid-ref the-last-stack)) - (save-stack 2) - (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)) - ;;; {Deprecated stuff} @@ -3719,8 +3362,10 @@ module '(ice-9 q) '(make-q q-length))}." ;; 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.