;; 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
(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
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)))))
\f
\f
+;;; {Structs}
+;;;
+
+(define (make-struct/no-tail vtable . args)
+ (apply make-struct vtable 0 args))
+
+\f
+
;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
(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)
(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)))))
+
+
\f
;;; {Defmacros}
;;; {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))))))
\f
(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)))))
\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)))
;;; {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))))
;;; {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))))
(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))
;;; {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)))))
\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))
(define (tms:cutime obj) (vector-ref obj 3))
(define (tms:cstime obj) (vector-ref obj 4))
+\f
+
+;;; {File Descriptors and Ports}
+;;;
+
(define file-position ftell)
(define* (file-set-position port offset #:optional (whence SEEK_SET))
(seek port offset whence))
;;; {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)
(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)
(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
(%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)
\f
-;;; {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))))))))
-
-
-\f
-
;;; {Low Level Modules}
;;;
;;; These are the low level data structures for modules.
version
submodules
submodule-binder
- public-interface)))
+ public-interface
+ filename)))
;; make-module &opt size uses binder
;; 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)))
-
- ;; We can't pass this as an argument to module-constructor,
- ;; because we need it to close over a pointer to the module
- ;; itself.
- (set-module-eval-closure! module (standard-eval-closure module))
+(define* (make-module #:optional (size 31) (uses '()) (binder #f))
+ (define %default-import-size
+ ;; Typical number of imported bindings actually used by a module.
+ 600)
+
+ (if (not (integer? size))
+ (error "Illegal size to make-module." size))
+ (if (not (and (list? uses)
+ (and-map module? uses)))
+ (error "Incorrect use list." uses))
+ (if (and binder (not (procedure? binder)))
+ (error
+ "Lazy-binder expected to be a procedure or #f." binder))
+
+ (let ((module (module-constructor (make-hash-table size)
+ uses binder #f macroexpand
+ #f #f #f
+ (make-hash-table %default-import-size)
+ '()
+ (make-weak-key-hash-table 31) #f
+ (make-hash-table 7) #f #f #f)))
+
+ ;; We can't pass this as an argument to module-constructor,
+ ;; because we need it to close over a pointer to the module
+ ;; itself.
+ (set-module-eval-closure! module (standard-eval-closure module))
- module))))
+ module))
\f
(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))
(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)))
;; 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)
;; or its public interface is not available. Signal "no binding"
;; error if selected binding does not exist in the used module.
;;
-(define (resolve-interface name . args)
-
- (define (get-keyword-arg args kw def)
- (cond ((memq kw args)
- => (lambda (kw-arg)
- (if (null? (cdr kw-arg))
- (error "keyword without value: " kw))
- (cadr kw-arg)))
- (else
- def)))
-
- (let* ((select (get-keyword-arg args #:select #f))
- (hide (get-keyword-arg args #:hide '()))
- (renamer (or (get-keyword-arg args #:renamer #f)
- (let ((prefix (get-keyword-arg args #:prefix #f)))
- (and prefix (symbol-prefix-proc prefix)))
- identity))
- (version (get-keyword-arg args #:version #f))
- (module (resolve-module name #t version))
+(define* (resolve-interface name #:key
+ (select #f)
+ (hide '())
+ (prefix #f)
+ (renamer (if prefix
+ (symbol-prefix-proc prefix)
+ identity))
+ 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))
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)
(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
;; This function is called from "modules.c". If you change it, be
;; sure to update "modules.c" as well.
-(define (try-module-autoload module-name . args)
+(define* (try-module-autoload module-name #:optional version)
(let* ((reverse-name (reverse module-name))
(name (symbol->string (car reverse-name)))
- (version (and (not (null? args)) (car args)))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
(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))))
;;; {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
\f
-;;; {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)))
+\f
-(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))
(define before-print-hook (make-hook 1))
(define after-print-hook (make-hook 1))
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
;;; The default repl-reader function. We may override this if we've
;;; the readline library.
(define repl-reader
- (lambda (prompt . reader)
+ (lambda* (prompt #:optional (reader (fluid-ref current-reader)))
(if (not (char-ready?))
(display (if (string? prompt) prompt (prompt))))
(force-output)
(run-hook before-read-hook)
- ((or (and (pair? reader) (car reader))
- (fluid-ref current-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))))
+ ((or reader read) (current-input-port))))
\f
\f
-;;; {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))
-
-\f
-
;;; {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)))))))
\f
;; Return a list of expressions that evaluate to the appropriate
;; arguments for resolve-interface according to SPEC.
-(eval-when
- (compile)
- (if (memq 'prefix (read-options))
- (error "boot-9 must be compiled with #:kw, not :kw")))
+(eval-when (compile)
+ (if (memq 'prefix (read-options))
+ (error "boot-9 must be compiled with #:kw, not :kw")))
(define (keyword-like-symbol->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
;; FIXME: we really need to clean up the guts of the module system.
;; We can compile to something better than process-define-module.
+;;
(define-syntax define-module
(lambda (x)
(define (keyword-like? stx)
(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)))))))
(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))
(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 ...)
;;; {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 . converter)
- (let ((fluid (make-fluid))
- (converter (if (null? converter)
- identity
- (car converter))))
- (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))))))
+
\f
(append (hashq-ref %cond-expand-table mod '())
features)))))
-(define-macro (cond-expand . clauses)
- (let ((syntax-error (lambda (cl)
- (error "invalid clause in `cond-expand'" cl))))
- (letrec
- ((test-clause
- (lambda (clause)
- (cond
- ((symbol? clause)
- (or (memq clause %cond-expand-features)
- (let lp ((uses (module-uses (current-module))))
- (if (pair? uses)
- (or (memq clause
- (hashq-ref %cond-expand-table
- (car uses) '()))
- (lp (cdr uses)))
- #f))))
- ((pair? clause)
- (cond
- ((eq? 'and (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #t)
- ((pair? l)
- (and (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'or (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #f)
- ((pair? l)
- (or (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'not (car clause))
- (cond ((not (pair? (cdr clause)))
- (syntax-error clause))
- ((pair? (cddr clause))
- ((syntax-error clause))))
- (not (test-clause (cadr clause))))
- (else
- (syntax-error clause))))
- (else
- (syntax-error clause))))))
- (let lp ((c clauses))
- (cond
- ((null? c)
- (error "Unfulfilled `cond-expand'"))
- ((not (pair? c))
- (syntax-error c))
- ((not (pair? (car c)))
- (syntax-error (car c)))
- ((test-clause (caar c))
- `(begin ,@(cdar c)))
- ((eq? (caar c) 'else)
- (if (pair? (cdr c))
- (syntax-error c))
- `(begin ,@(cdar c)))
- (else
- (lp (cdr c))))))))
+(define-syntax cond-expand
+ (lambda (x)
+ (define (module-has-feature? mod sym)
+ (or-map (lambda (mod)
+ (memq sym (hashq-ref %cond-expand-table mod '())))
+ (module-uses mod)))
+
+ (define (condition-matches? condition)
+ (syntax-case condition (and or not)
+ ((and c ...)
+ (and-map condition-matches? #'(c ...)))
+ ((or c ...)
+ (or-map condition-matches? #'(c ...)))
+ ((not c)
+ (if (condition-matches? #'c) #f #t))
+ (c
+ (identifier? #'c)
+ (let ((sym (syntax->datum #'c)))
+ (if (memq sym %cond-expand-features)
+ #t
+ (module-has-feature? (current-module) sym))))))
+
+ (define (match clauses alternate)
+ (syntax-case clauses ()
+ (((condition form ...) . rest)
+ (if (condition-matches? #'condition)
+ #'(begin form ...)
+ (match #'rest alternate)))
+ (() (alternate))))
+
+ (syntax-case x (else)
+ ((_ clause ... (else form ...))
+ (match #'(clause ...)
+ (lambda ()
+ #'(begin form ...))))
+ ((_ clause ...)
+ (match #'(clause ...)
+ (lambda ()
+ (syntax-violation 'cond-expand "unfulfilled cond-expand" x)))))))
;; This procedure gets called from the startup code with a list of
;; numbers, which are the numbers of the SRFIs to be loaded on startup.
;;; srfi-55: require-extension
;;;
-(define-macro (require-extension extension-spec)
- ;; This macro only handles the srfi extension, which, at present, is
- ;; the only one defined by the standard.
- (if (not (pair? extension-spec))
- (scm-error 'wrong-type-arg "require-extension"
- "Not an extension: ~S" (list extension-spec) #f))
- (let ((extension (car extension-spec))
- (extension-args (cdr extension-spec)))
- (case extension
- ((srfi)
- (let ((use-list '()))
- (for-each
- (lambda (i)
- (if (not (integer? i))
- (scm-error 'wrong-type-arg "require-extension"
- "Invalid srfi name: ~S" (list i) #f))
- (let ((srfi-sym (string->symbol
- (string-append "srfi-" (number->string i)))))
- (if (not (memq srfi-sym %cond-expand-features))
- (set! use-list (cons `(use-modules (srfi ,srfi-sym))
- use-list)))))
- extension-args)
- (if (pair? use-list)
- ;; i.e. (begin (use-modules x) (use-modules y) (use-modules z))
- `(begin ,@(reverse! use-list)))))
- (else
- (scm-error
- 'wrong-type-arg "require-extension"
- "Not a recognized extension type: ~S" (list extension) #f)))))
-
-\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)))))
\f
(lambda () (fluid-ref using-readline?))
(lambda (v) (fluid-set! using-readline? v)))))
-(define (top-repl)
- (let ((guile-user-module (resolve-module '(guile-user))))
-
- ;; Load emacs interface support if emacs option is given.
- (if (and (module-defined? guile-user-module 'use-emacs-interface)
- (module-ref guile-user-module 'use-emacs-interface))
- (load-emacs-interface))
-
- ;; Use some convenient modules (in reverse order)
-
- (set-current-module guile-user-module)
- (process-use-modules
- (append
- '(((ice-9 r5rs))
- ((ice-9 session))
- ((ice-9 debug)))
- (if (provided? 'regex)
- '(((ice-9 regex)))
- '())
- (if (provided? 'threads)
- '(((ice-9 threads)))
- '())))
- ;; load debugger on demand
- (module-autoload! guile-user-module '(system vm debug) '(debug))
-
- ;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
- ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
- ;; no effect.
- (let ((old-handlers #f)
- (start-repl (module-ref (resolve-interface '(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))
-
\f
;;; {Deprecated stuff}
;;; Place the user in the guile-user module.
;;;
-;;; FIXME: annotate ?
-;; (define (syncase exp)
-;; (with-fluids ((expansion-eval-closure
-;; (module-eval-closure (current-module))))
-;; (deannotate/source-properties (macroexpand (annotate exp)))))
-
;; FIXME:
(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
HCoop / bpt / guile.git / blobdiff