X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/3ece779a677d0316c506c30051a928ba40060479..e9729cbb2ce87f635353039385c140f2355bd47d:/module/ice-9/boot-9.scm diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index c6b761f22..138cf59ff 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -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...) ...) @@ -337,15 +346,11 @@ If there is no handler at all, Guile prints an error and then exits." (define (resolve-module . args) #f) -;; Input hook to syncase -- so that we might be able to pass annotated -;; expressions in. Currently disabled. Maybe we should just use -;; source-properties directly. -(define (annotation? x) #f) - ;; API provided by psyntax (define syntax-violation #f) (define datum->syntax #f) (define syntax->datum #f) +(define syntax-source #f) (define identifier? #f) (define generate-temporaries #f) (define bound-identifier=? #f) @@ -460,6 +465,14 @@ If there is no handler at all, Guile prints an error and then exits." (include-from-path "ice-9/quasisyntax") +(define-syntax current-source-location + (lambda (x) + (syntax-case x () + ((_) + (with-syntax ((s (datum->syntax x (syntax-source x)))) + #''s))))) + + ;;; {Defmacros} @@ -503,13 +516,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)))))) @@ -520,35 +534,28 @@ If there is no handler at all, Guile prints an error and then exits." (define (and=> value procedure) (and value (procedure value))) (define call/cc call-with-current-continuation) -;;; apply-to-args is functionally redundant with apply and, worse, -;;; is less general than apply since it only takes two arguments. -;;; -;;; On the other hand, apply-to-args is a syntacticly convenient way to -;;; perform binding in many circumstances when the "let" family of -;;; of forms don't cut it. E.g.: -;;; -;;; (apply-to-args (return-3d-mouse-coords) -;;; (lambda (x y z) -;;; ...)) -;;; - -(define (apply-to-args args fn) (apply fn args)) - -(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))))) ;;; {General Properties} ;;; -;; This is a more modern interface to properties. It will replace all -;; other property-like things eventually. +;; Properties are a lispy way to associate random info with random objects. +;; Traditionally properties are implemented as an alist or a plist actually +;; pertaining to the object in question. +;; +;; These "object properties" have the advantage that they can be associated with +;; any object, even if the object has no plist. Object properties are good when +;; you are extending pre-existing objects in unexpected ways. They also present +;; a pleasing, uniform procedure-with-setter interface. But if you have a data +;; type that always has properties, it's often still best to store those +;; properties within the object itself. (define (make-object-property) (let ((prop (primitive-make-property #f))) @@ -561,6 +568,10 @@ If there is no handler at all, Guile prints an error and then exits." ;;; {Symbol Properties} ;;; +;;; Symbol properties are something you see in old Lisp code. In most current +;;; Guile code, symbols are not used as a data structure -- they are used as +;;; keys into other data structures. + (define (symbol-property sym prop) (let ((pair (assoc prop (symbol-pref sym)))) (and pair (cdr pair)))) @@ -590,6 +601,8 @@ If there is no handler at all, Guile prints an error and then exits." ;;; {Keywords} ;;; +;;; It's much better if you can use lambda* / define*, of course. + (define (kw-arg-ref args kw) (let ((rem (member kw args))) (and rem (pair? (cdr rem)) (cadr rem)))) @@ -831,9 +844,6 @@ If there is no handler at all, Guile prints an error and then exits." (if port (begin (close-port port) #t) #f))))) -(define (has-suffix? str suffix) - (string-suffix? suffix str)) - (define (system-error-errno args) (if (eq? (car args) 'system-error) (car (list-ref args 4)) @@ -844,30 +854,19 @@ If there is no handler at all, Guile prints an error and then exits." ;;; {Error Handling} ;;; -(define (error . args) - (save-stack) - (if (null? args) - (scm-error 'misc-error #f "?" #f #f) - (let loop ((msg "~A") - (rest (cdr args))) - (if (not (null? rest)) - (loop (string-append msg " ~S") - (cdr rest)) - (scm-error 'misc-error #f msg args #f))))) - -;; bad-throw is the hook that is called upon a throw to a an unhandled -;; key (unless the throw has four arguments, in which case -;; it's usually interpreted as an error throw.) -;; If the key has a default handler (a throw-handler-default property), -;; it is applied to the throw. -;; -(define (bad-throw key . args) - (let ((default (symbol-property key 'throw-handler-default))) - (or (and default (apply default key args)) - (apply error "unhandled-exception:" key args)))) +(define error + (case-lambda + (() + (scm-error 'misc-error #f "?" #f #f)) + ((message . args) + (let ((msg (string-join (cons "~A" (make-list (length args) "~S"))))) + (scm-error 'misc-error #f msg (cons message args) #f))))) +;;; {Time Structures} +;;; + (define (tm:sec obj) (vector-ref obj 0)) (define (tm:min obj) (vector-ref obj 1)) (define (tm:hour obj) (vector-ref obj 2)) @@ -898,6 +897,11 @@ If there is no handler at all, Guile prints an error and then exits." (define (tms:cutime obj) (vector-ref obj 3)) (define (tms:cstime obj) (vector-ref obj 4)) + + +;;; {File Descriptors and Ports} +;;; + (define file-position ftell) (define* (file-set-position port offset #:optional (whence SEEK_SET)) (seek port offset whence)) @@ -998,10 +1002,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) @@ -1056,7 +1056,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) @@ -1116,7 +1116,7 @@ If there is no handler at all, Guile prints an error and then exits." (lambda () (let* ((scmstat (stat name)) (gostat (stat go-path #f))) - (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat))) + (if (and gostat (>= (stat:mtime gostat) (stat:mtime scmstat))) go-path (begin (if gostat @@ -1127,6 +1127,10 @@ If there is no handler at all, Guile prints an error and then exits." (%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) @@ -1164,130 +1168,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. @@ -1572,7 +1452,8 @@ If there is no handler at all, Guile prints an error and then exits." version submodules submodule-binder - public-interface))) + public-interface + filename))) ;; make-module &opt size uses binder @@ -1580,48 +1461,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)) - - (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))) +(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)) - ;; 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)) @@ -2201,12 +2068,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)) @@ -2295,101 +2173,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))))))) - (numlist-less (car pair1) (car pair2))) - (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 (append (car root-pair) (list num))))) - (if (and num (eq? (stat:type (stat subdir)) 'directory)) - (filter-subdir - root-pair dstrm (cons (cons num 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))) @@ -2404,25 +2213,26 @@ If there is no handler at all, Guile prints an error and then exits." ;; Define the-root-module as '(guile). (module-define-submodule! root 'guile the-root-module) - (lambda* (name #:optional (autoload #t) (version #f)) + (lambda* (name #:optional (autoload #t) (version #f) #:key (ensure #t)) (let ((already (nested-ref-module root name))) (cond ((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) (autoload ;; Try to autoload the module, and recurse. (try-load-module name version) - (resolve-module name #f)) + (resolve-module name #f #:ensure ensure)) (else ;; No module found (or if one was, it had no public interface), and - ;; we're not autoloading. Here's the weird semantics: we ensure - ;; there's an empty module. - (or already (make-modules-in root name)))))))) + ;; we're not autoloading. Make an empty module if #:ensure is true. + (or already + (and ensure + (make-modules-in root name))))))))) (define (try-load-module name version) @@ -2477,7 +2287,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)) @@ -2641,6 +2451,16 @@ If there is no handler at all, Guile prints an error and then exits." 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))))) (run-hook module-defined-hook module) @@ -2670,7 +2490,7 @@ If there is no handler at all, Guile prints an error and then exits." (module-local-variable i sym)))))) (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f (make-hash-table 0) '() (make-weak-value-hash-table 31) #f - (make-hash-table 0) #f #f))) + (make-hash-table 0) #f #f #f))) (define (module-autoload! module . args) "Have @var{module} automatically load the module named @var{name} when one @@ -2717,10 +2537,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)))) @@ -2762,58 +2588,42 @@ 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-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) + (options (append (options) (list 'opt val)))))))))) (define-option-interface (eval-options-interface @@ -2842,211 +2652,54 @@ 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)) +;;; {Running Repls} +;;; -;; 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 (error-catching-loop thunk) - (let ((status #f) - (interactive #t)) - (define (loop first) - (let ((next - (catch #t - - (lambda () - (call-with-unblocked-asyncs - (lambda () - (with-traps - (lambda () - (first) - - ;; This line is needed because mark - ;; doesn't do closures quite right. - ;; Unreferenced locals should be - ;; collected. - (set! first #f) - (let loop ((v (thunk))) - (loop (thunk))) - #f))))) - - (lambda (key . args) - (case key - ((quit) - (set! status args) - #f) - - ((switch-repl) - (apply throw 'switch-repl args)) - - ((abort) - ;; This is one of the closures that require - ;; (set! first #f) above - ;; - (lambda () - (run-hook abort-hook) - (force-output (current-output-port)) - (display "ABORT: " (current-error-port)) - (write args (current-error-port)) - (newline (current-error-port)) - (if interactive - (begin - (if (and - (not has-shown-debugger-hint?) - (not (memq 'backtrace - (debug-options-interface))) - (stack? (fluid-ref the-last-stack))) - (begin - (newline (current-error-port)) - (display - "Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n" - (current-error-port)) - (set! has-shown-debugger-hint? #t))) - (force-output (current-error-port))) - (begin - (primitive-exit 1))) - (set! stack-saved? #f))) +(define *repl-stack* (make-fluid)) - (else - ;; This is the other cons-leak closure... - (lambda () - (cond ((= (length args) 4) - (apply handle-system-error key args)) - (else - (apply bad-throw key args))))))) - - default-pre-unwind-handler))) - - (if next (loop next) status))) - (set! set-batch-mode?! (lambda (arg) - (cond (arg - (set! interactive #f) - (restore-signals)) - (#t - (error "sorry, not implemented"))))) - (set! batch-mode? (lambda () (not interactive))) - (call-with-blocked-asyncs - (lambda () (loop (lambda () #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) - -(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 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)) (define exit quit) -;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace () - -;; Replaced by C code: -;;(define (backtrace) -;; (if (fluid-ref the-last-stack) -;; (begin -;; (newline) -;; (display-backtrace (fluid-ref the-last-stack) (current-output-port)) -;; (newline) -;; (if (and (not has-shown-backtrace-hint?) -;; (not (memq 'backtrace (debug-options-interface)))) -;; (begin -;; (display -;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace -;;automatically if an error occurs in the future.\n") -;; (set! has-shown-backtrace-hint? #t)))) -;; (display "No backtrace available.\n"))) - -(define (error-catching-repl r e p) - (error-catching-loop - (lambda () - (call-with-values (lambda () (e (r))) - (lambda the-values (for-each p the-values)))))) - (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)) @@ -3054,6 +2707,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 @@ -3064,113 +2721,6 @@ module '(ice-9 q) '(make-q q-length))}." (run-hook before-read-hook) ((or reader read) (current-input-port)))) -(define (scm-style-repl) - - (letrec ( - (start-gc-rt #f) - (start-rt #f) - (repl-report-start-timing (lambda () - (set! start-gc-rt (gc-run-time)) - (set! start-rt (get-internal-run-time)))) - (repl-report (lambda () - (display ";;; ") - (display (inexact->exact - (* 1000 (/ (- (get-internal-run-time) start-rt) - internal-time-units-per-second)))) - (display " msec (") - (display (inexact->exact - (* 1000 (/ (- (gc-run-time) start-gc-rt) - internal-time-units-per-second)))) - (display " msec in gc)\n"))) - - (consume-trailing-whitespace - (lambda () - (let ((ch (peek-char))) - (cond - ((eof-object? ch)) - ((or (char=? ch #\space) (char=? ch #\tab)) - (read-char) - (consume-trailing-whitespace)) - ((char=? ch #\newline) - (read-char)))))) - (-read (lambda () - (let ((val - (let ((prompt (cond ((string? scm-repl-prompt) - scm-repl-prompt) - ((thunk? scm-repl-prompt) - (scm-repl-prompt)) - (scm-repl-prompt "> ") - (else "")))) - (repl-reader prompt)))) - - ;; As described in R4RS, the READ procedure updates the - ;; port to point to the first character past the end of - ;; the external representation of the object. This - ;; means that it doesn't consume the newline typically - ;; found after an expression. This means that, when - ;; debugging Guile with GDB, GDB gets the newline, which - ;; it often interprets as a "continue" command, making - ;; breakpoints kind of useless. So, consume any - ;; trailing newline here, as well as any whitespace - ;; before it. - ;; But not if EOF, for control-D. - (if (not (eof-object? val)) - (consume-trailing-whitespace)) - (run-hook after-read-hook) - (if (eof-object? val) - (begin - (repl-report-start-timing) - (if scm-repl-verbose - (begin - (newline) - (display ";;; EOF -- quitting") - (newline))) - (quit 0))) - val))) - - (-eval (lambda (sourc) - (repl-report-start-timing) - (run-hook before-eval-hook sourc) - (let ((val (start-stack 'repl-stack - ;; If you change this procedure - ;; (primitive-eval), please also - ;; modify the repl-stack case in - ;; save-stack so that stack cutting - ;; continues to work. - (primitive-eval sourc)))) - (run-hook after-eval-hook sourc) - val))) - - - (-print (let ((maybe-print (lambda (result) - (if (or scm-repl-print-unspecified - (not (unspecified? result))) - (begin - (write result) - (newline)))))) - (lambda (result) - (if (not scm-repl-silent) - (begin - (run-hook before-print-hook result) - (maybe-print result) - (run-hook after-print-hook result) - (if scm-repl-verbose - (repl-report)) - (force-output)))))) - - (-quit (lambda (args) - (if scm-repl-verbose - (begin - (display ";;; QUIT executed, repl exitting") - (newline) - (repl-report))) - args))) - - (let ((status (error-catching-repl -read - -eval - -print))) - (-quit status)))) - @@ -3184,46 +2734,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))))))) @@ -3234,16 +2789,16 @@ 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) @@ -3311,7 +2866,11 @@ module '(ice-9 q) '(make-q q-length))}." (with-syntax (((quoted-arg ...) (quotify #'(arg ...)))) #'(eval-when (eval load compile expand) (let ((m (process-define-module - (list '(name name* ...) quoted-arg ...)))) + (list '(name name* ...) + #:filename (assq-ref + (or (current-source-location) '()) + 'filename) + quoted-arg ...)))) (set-current-module m) m))))))) @@ -3442,7 +3001,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)) @@ -3482,6 +3041,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 ...) @@ -3499,16 +3066,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)))))) + @@ -3680,66 +3244,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. @@ -3756,48 +3299,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))))) @@ -3807,90 +3324,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) - (start-repl (@ (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}