(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}
(set! %load-hook %load-announce)
-(define (load name . reader)
+(define* (load name #:optional reader)
;; Returns the .go file corresponding to `name'. Does not search load
;; paths, only the fallback path. If the .go file is missing or out of
;; date, and autocompilation is enabled, will try autocompilation, just
(%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)
";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
name k args)
#f)))
- (with-fluids ((current-reader (and (pair? reader) (car reader))))
+ (with-fluids ((current-reader reader))
(let ((cfn (and=> (and=> (false-if-exception (canonicalize-path name))
compiled-file-name)
fresh-compiled-file-name)))
version
submodules
submodule-binder
- public-interface)))
+ public-interface
+ filename)))
;; make-module &opt size uses binder
(make-hash-table %default-import-size)
'()
(make-weak-key-hash-table 31) #f
- (make-hash-table 7) #f #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
(set-module-observers! module (cons proc (module-observers module)))
(cons module proc))
-(define (module-observe-weak module observer-id . proc)
+(define* (module-observe-weak module observer-id #:optional (proc observer-id))
;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can
;; be any Scheme object). PROC is invoked and passed MODULE any time
;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd
;; The two-argument version is kept for backward compatibility: when called
;; with two arguments, the observer gets unregistered when closure PROC
;; gets GC'd (making it impossible to use an anonymous lambda for PROC).
-
- (let ((proc (if (null? proc) observer-id (car proc))))
- (hashq-set! (module-weak-observers module) observer-id proc)))
+ (hashq-set! (module-weak-observers module) observer-id proc))
(define (module-unobserve token)
(let ((module (car token))
(define basic-load load)
-(define (load-module filename . reader)
+(define* (load-module filename #:optional reader)
(save-module-excursion
(lambda ()
(let ((oldname (and (current-load-port)
(port-filename (current-load-port)))))
- (apply basic-load
- (if (and oldname
- (> (string-length filename) 0)
- (not (char=? (string-ref filename 0) #\/))
- (not (string=? (dirname oldname) ".")))
- (string-append (dirname oldname) "/" filename)
- filename)
- reader)))))
+ (basic-load (if (and oldname
+ (> (string-length filename) 0)
+ (not (char=? (string-ref filename 0) #\/))
+ (not (string=? (dirname oldname) ".")))
+ (string-append (dirname oldname) "/" filename)
+ filename)
+ reader)))))
\f
(cond ((> (car lst1) (car lst2)) #t)
((< (car lst1) (car lst2)) #f)
(else (numlist-less (cdr lst1) (cdr lst2)))))))
- (numlist-less (car pair1) (car pair2)))
+ (not (numlist-less (car pair2) (car pair1))))
(define (match-version-and-file pair)
(and (version-matches? version-ref (car pair))
(let ((filenames
(let ((s (false-if-exception (stat file))))
(and s (eq? (stat:type s) 'regular))))
(map (lambda (ext)
- (string-append (cdr pair) "/" name ext))
+ (string-append (cdr pair) name ext))
%load-extensions))))
(and (not (null? filenames))
(cons (car pair) (car filenames))))))
(let ((entry (readdir dstrm)))
(if (eof-object? entry)
subdir-pairs
- (let* ((subdir (string-append (cdr root-pair) "/" entry))
+ (let* ((subdir (string-append (cdr root-pair) entry))
(num (string->number entry))
- (num (and num (append (car root-pair) (list num)))))
+ (num (and num (exact? num) (append (car root-pair)
+ (list num)))))
(if (and num (eq? (stat:type (stat subdir)) 'directory))
- (filter-subdir
- root-pair dstrm (cons (cons num subdir) subdir-pairs))
+ (filter-subdir
+ root-pair dstrm (cons (cons num (string-append subdir "/"))
+ subdir-pairs))
(filter-subdir root-pair dstrm subdir-pairs))))))
(or (and (null? root-pairs) ret)
;; Define the-root-module as '(guile).
(module-define-submodule! root 'guile the-root-module)
- (lambda (name . args) ;; #:optional (autoload #t) (version #f)
- (let* ((already (nested-ref-module root name))
- (numargs (length args))
- (autoload (or (= numargs 0) (car args)))
- (version (and (> numargs 1) (cadr args))))
+ (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)))
(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))
(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)
(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)))
-
- (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 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))))
;;; 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
(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)))))))
(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))))
+ (lambda* (init #:optional (converter identity))
+ (let ((fluid (make-fluid)))
(fluid-set! fluid (converter init))
(make fluid converter)))))
;; 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))
+ ;; We can't use @ here, as modules have been booted, but in Guile's
+ ;; build the srfi-1 helper lib hasn't been built yet, which will
+ ;; result in an error when (system repl repl) is loaded at compile
+ ;; time (to see if it is a macro or not).
+ (start-repl (module-ref (resolve-module '(system repl repl))
'start-repl))
(signals (if (provided? 'posix)
`((,SIGINT . "User interrupt")
;;; 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