;; (eval-case ((situation*) forms)* (else forms)?)
;;
;; Evaluate certain code based on the situation that eval-case is used
-;; in. The only defined situation right now is `load-toplevel' which
-;; triggers for code evaluated at the top-level, for example from the
-;; REPL or when loading a file.
+;; in. There are three situations defined. `load-toplevel' triggers for
+;; code evaluated at the top-level, for example from the REPL or when
+;; loading a file. `compile-toplevel' triggers for code compiled at the
+;; toplevel. `execute' triggers during execution of code not at the top
+;; level.
(define eval-case
(procedure->memoizing-macro
\f
+;; Before compiling, make sure any symbols are resolved in the (guile)
+;; module, the primary location of those symbols, rather than in
+;; (guile-user), the default module that we compile in.
+
+(eval-case
+ ((compile-toplevel)
+ (set-current-module (resolve-module '(guile)))))
+
;;; {Defmacros}
;;;
;;; Depends on: features, eval-case
(lambda (name parms . body)
(let ((transformer `(lambda ,parms ,@body)))
`(eval-case
- ((load-toplevel)
- (define ,name (defmacro:transformer ,transformer)))
+ ((load-toplevel compile-toplevel)
+ (define ,name (defmacro:transformer ,transformer)))
(else
(error "defmacro can only be used at the top level")))))))
(defmacro:transformer defmacro-transformer)))
-(define defmacro:syntax-transformer
- (lambda (f)
- (procedure->syntax
- (lambda (exp env)
- (copy-tree (apply f (cdr exp)))))))
-
;; XXX - should the definition of the car really be looked up in the
;; current module?
(defmacro begin-deprecated forms
(if (include-deprecated-features)
- (cons begin forms)
- #f))
+ `(begin ,@forms)
+ (begin)))
\f
;;; {R4RS compliance}
;;;
-(primitive-load-path "ice-9/r4rs.scm")
+(primitive-load-path "ice-9/r4rs")
\f
\f
-;;; {Environments}
-;;;
-
-(define the-environment
- (procedure->syntax
- (lambda (x e)
- e)))
-
-(define the-root-environment (the-environment))
-
-(define (environment-module env)
- (let ((closure (and (pair? env) (car (last-pair env)))))
- (and closure (procedure-property closure 'module))))
-
-\f
-
;;; {Records}
;;;
(define (record-constructor rtd . opt)
(let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
- (local-eval `(lambda ,field-names
- (make-struct ',rtd 0 ,@(map (lambda (f)
- (if (memq f field-names)
- f
- #f))
- (record-type-fields rtd))))
- the-root-environment)))
-
+ (primitive-eval
+ `(lambda ,field-names
+ (make-struct ',rtd 0 ,@(map (lambda (f)
+ (if (memq f field-names)
+ f
+ #f))
+ (record-type-fields rtd)))))))
+
(define (record-predicate rtd)
(lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
#f)))
(define (record-accessor rtd field-name)
- (let* ((pos (list-index (record-type-fields rtd) field-name)))
+ (let ((pos (list-index (record-type-fields rtd) field-name)))
(if (not pos)
(error 'no-such-field field-name))
- (local-eval `(lambda (obj)
- (if (eq? (struct-vtable obj) ,rtd)
- (struct-ref obj ,pos)
- (%record-type-error ,rtd obj)))
- the-root-environment)))
+ (lambda (obj)
+ (if (eq? (struct-vtable obj) rtd)
+ (struct-ref obj pos)
+ (%record-type-error rtd obj)))))
(define (record-modifier rtd field-name)
- (let* ((pos (list-index (record-type-fields rtd) field-name)))
+ (let ((pos (list-index (record-type-fields rtd) field-name)))
(if (not pos)
(error 'no-such-field field-name))
- (local-eval `(lambda (obj val)
- (if (eq? (struct-vtable obj) ,rtd)
- (struct-set! obj ,pos val)
- (%record-type-error ,rtd obj)))
- the-root-environment)))
-
+ (lambda (obj val)
+ (if (eq? (struct-vtable obj) rtd)
+ (struct-set! obj pos val)
+ (%record-type-error rtd obj)))))
(define (record? obj)
(and (struct? obj) (record-type? (struct-vtable obj))))
\f
(if (provided? 'posix)
- (primitive-load-path "ice-9/posix.scm"))
+ (primitive-load-path "ice-9/posix"))
(if (provided? 'socket)
- (primitive-load-path "ice-9/networking.scm"))
+ (primitive-load-path "ice-9/networking"))
;; For reference, Emacs file-exists-p uses stat in this same way.
;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in
#f)))))
(define (has-suffix? str suffix)
- (let ((sufl (string-length suffix))
- (sl (string-length str)))
- (and (> sl sufl)
- (string=? (substring str (- sl sufl) sl) suffix))))
+ (string-suffix? suffix str))
(define (system-error-errno args)
(if (eq? (car args) 'system-error)
\f
+;;; {The interpreter stack}
+;;;
+
+(defmacro start-stack (tag exp)
+ `(%start-stack ,tag (lambda () ,exp)))
+
+\f
+
;;; {Loading by paths}
;;;
;; NOTE: This binding is used in libguile/modules.c.
;;
-(define (resolve-module name . maybe-autoload)
- (let ((full-name (append '(%app modules) name)))
- (let ((already (nested-ref the-root-module full-name)))
- (if already
- ;; The module already exists...
- (if (and (or (null? maybe-autoload) (car maybe-autoload))
- (not (module-public-interface already)))
- ;; ...but we are told to load and it doesn't contain source, so
- (begin
- (try-load-module name)
- already)
- ;; simply return it.
- already)
- (begin
- ;; Try to autoload it if we are told so
- (if (or (null? maybe-autoload) (car maybe-autoload))
- (try-load-module name))
- ;; Get/create it.
- (make-modules-in (current-module) full-name))))))
+(define resolve-module
+ (let ((the-root-module the-root-module))
+ (lambda (name . maybe-autoload)
+ (if (equal? name '(guile))
+ the-root-module
+ (let ((full-name (append '(%app modules) name)))
+ (let ((already (nested-ref the-root-module full-name)))
+ (if already
+ ;; The module already exists...
+ (if (and (or (null? maybe-autoload) (car maybe-autoload))
+ (not (module-public-interface already)))
+ ;; ...but we are told to load and it doesn't contain source, so
+ (begin
+ (try-load-module name)
+ already)
+ ;; simply return it.
+ already)
+ (begin
+ ;; Try to autoload it if we are told so
+ (if (or (null? maybe-autoload) (car maybe-autoload))
+ (try-load-module name))
+ ;; Get/create it.
+ (make-modules-in (current-module) full-name)))))))))
;; Cheat. These bindings are needed by modules.c, but we don't want
;; to move their real definition here because that would be unnatural.
(define module-export! #f)
(define default-duplicate-binding-procedures #f)
-;; This boots the module system. All bindings needed by modules.c
-;; must have been defined by now.
-;;
-(set-current-module the-root-module)
-
(define %app (make-module 31))
(define app %app) ;; for backwards compatability
+
(local-define '(%app modules) (make-module 31))
(local-define '(%app modules guile) the-root-module)
+;; This boots the module system. All bindings needed by modules.c
+;; must have been defined by now.
+;;
+(set-current-module the-root-module)
+
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
(define (try-load-module name)
(error "unrecognized define-module argument" arg))))
(beautify-user-module! module)
(let loop ((kws kws)
- (reversed-interfaces '())
- (exports '())
- (re-exports '())
- (replacements '())
+ (reversed-interfaces '())
+ (exports '())
+ (re-exports '())
+ (replacements '())
(autoloads '()))
(if (null? kws)
- (call-with-deferred-observers
- (lambda ()
- (module-use-interfaces! module (reverse reversed-interfaces))
- (module-export! module exports)
- (module-replace! module replacements)
- (module-re-export! module re-exports)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-use-interfaces! module (reverse reversed-interfaces))
+ (module-export! module exports)
+ (module-replace! module replacements)
+ (module-re-export! module re-exports)
(if (not (null? autoloads))
(apply module-autoload! module autoloads))))
- (case (car kws)
- ((#:use-module #:use-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (let* ((interface-args (cadr kws))
- (interface (apply resolve-interface interface-args)))
- (and (eq? (car kws) #:use-syntax)
- (or (symbol? (caar interface-args))
- (error "invalid module name for use-syntax"
- (car interface-args)))
- (set-module-transformer!
- module
- (module-ref interface
- (car (last-pair (car interface-args)))
- #f)))
- (loop (cddr kws)
- (cons interface reversed-interfaces)
- exports
- re-exports
- replacements
+ (case (car kws)
+ ((#:use-module #:use-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (let* ((interface-args (cadr kws))
+ (interface (apply resolve-interface interface-args)))
+ (and (eq? (car kws) #:use-syntax)
+ (or (symbol? (caar interface-args))
+ (error "invalid module name for use-syntax"
+ (car interface-args)))
+ (set-module-transformer!
+ module
+ (module-ref interface
+ (car (last-pair (car interface-args)))
+ #f)))
+ (loop (cddr kws)
+ (cons interface reversed-interfaces)
+ exports
+ re-exports
+ replacements
autoloads)))
- ((#:autoload)
- (or (and (pair? (cdr kws)) (pair? (cddr kws)))
- (unrecognized kws))
- (loop (cdddr kws)
+ ((#:autoload)
+ (or (and (pair? (cdr kws)) (pair? (cddr kws)))
+ (unrecognized kws))
+ (loop (cdddr kws)
reversed-interfaces
- exports
- re-exports
- replacements
+ exports
+ re-exports
+ replacements
(let ((name (cadr kws))
(bindings (caddr kws)))
(cons* name bindings autoloads))))
- ((#:no-backtrace)
- (set-system-module! module #t)
- (loop (cdr kws) reversed-interfaces exports re-exports
+ ((#:no-backtrace)
+ (set-system-module! module #t)
+ (loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
- ((#:pure)
- (purify-module! module)
- (loop (cdr kws) reversed-interfaces exports re-exports
+ ((#:pure)
+ (purify-module! module)
+ (loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
- ((#:duplicates)
- (if (not (pair? (cdr kws)))
- (unrecognized kws))
- (set-module-duplicates-handlers!
- module
- (lookup-duplicates-handlers (cadr kws)))
- (loop (cddr kws) reversed-interfaces exports re-exports
+ ((#:duplicates)
+ (if (not (pair? (cdr kws)))
+ (unrecognized kws))
+ (set-module-duplicates-handlers!
+ module
+ (lookup-duplicates-handlers (cadr kws)))
+ (loop (cddr kws) reversed-interfaces exports re-exports
replacements autoloads))
- ((#:export #:export-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- (append (cadr kws) exports)
- re-exports
- replacements
+ ((#:export #:export-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (loop (cddr kws)
+ reversed-interfaces
+ (append (cadr kws) exports)
+ re-exports
+ replacements
autoloads))
- ((#:re-export #:re-export-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- exports
- (append (cadr kws) re-exports)
- replacements
+ ((#:re-export #:re-export-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (loop (cddr kws)
+ reversed-interfaces
+ exports
+ (append (cadr kws) re-exports)
+ replacements
autoloads))
- ((#:replace #:replace-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- exports
- re-exports
- (append (cadr kws) replacements)
+ ((#:replace #:replace-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (loop (cddr kws)
+ reversed-interfaces
+ exports
+ re-exports
+ (append (cadr kws) replacements)
autoloads))
- (else
- (unrecognized kws)))))
+ (else
+ (unrecognized kws)))))
(run-hook module-defined-hook module)
module))
;;; {Compiled module}
-(define load-compiled #f)
+(if (not (defined? 'load-compiled))
+ (define load-compiled #f))
\f
(lambda () (autoload-in-progress! dir-hint name))
(lambda ()
(let ((file (in-vicinity dir-hint name)))
- (cond ((and load-compiled
- (%search-load-path (string-append file ".go")))
- => (lambda (full)
- (load-file load-compiled full)))
- ((%search-load-path file)
- => (lambda (full)
- (with-fluids ((current-reader #f))
- (load-file primitive-load full)))))))
+ (let ((compiled (and load-compiled
+ (%search-load-path
+ (string-append file ".go"))))
+ (source (%search-load-path file)))
+ (cond ((and source
+ (or (not compiled)
+ (< (stat:mtime (stat compiled))
+ (stat:mtime (stat source)))))
+ (if compiled
+ (warn "source file" source "newer than" compiled))
+ (with-fluids ((current-reader #f))
+ (load-file primitive-load source)))
+ (compiled
+ (load-file load-compiled compiled))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
;;; {Run-time options}
;;;
-(define define-option-interface
+(defmacro define-option-interface (option-group)
(let* ((option-name car)
(option-value cadr)
(option-documentation caddr)
- (print-option (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)))
-
;; Below follow the macros defining the run-time option interfaces.
(make-options (lambda (interface)
(cond ((null? args) (,interface))
((list? (car args))
(,interface (car args)) (,interface))
- (else (for-each ,print-option
- (,interface #t)))))))
+ (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
flags)
(,interface options)
(,interface))))))
- (procedure->memoizing-macro
- (lambda (exp env)
- (let* ((option-group (cadr exp))
- (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))))))))))
+ (let* ((interface (car option-group))
+ (options/enable/disable (cadr option-group)))
+ `(begin
+ (define ,(car options/enable/disable)
+ ,(make-options interface))
+ (define ,(cadr options/enable/disable)
+ ,(make-enable interface))
+ (define ,(caddr options/enable/disable)
+ ,(make-disable interface))
+ (defmacro ,(caaddr option-group) (opt val)
+ `(,',(car options/enable/disable)
+ (append (,',(car options/enable/disable))
+ (list ',opt ,val))))))))
(define-option-interface
(eval-options-interface
;;; the readline library.
(define repl-reader
(lambda (prompt)
- (display prompt)
+ (display (if (string? prompt) prompt (prompt)))
(force-output)
(run-hook before-read-hook)
((or (fluid-ref current-reader) read) (current-input-port))))
(car rest)
`(lambda ,(cdr first) ,@rest))))
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(define ,name (defmacro:transformer ,transformer)))
(else
(error "define-macro can only be used at the top level")))))
-(defmacro define-syntax-macro (first . rest)
- (let ((name (if (symbol? first) first (car first)))
- (transformer
- (if (symbol? first)
- (car rest)
- `(lambda ,(cdr first) ,@rest))))
- `(eval-case
- ((load-toplevel)
- (define ,name (defmacro:syntax-transformer ,transformer)))
- (else
- (error "define-syntax-macro can only be used at the top level")))))
-
\f
;;; {While}
;; This is probably a bug in syncase.
;;
(define-macro (while cond . body)
- (define (while-helper proc)
- (do ((key (make-symbol "while-key")))
- ((catch key
- (lambda ()
- (proc (lambda () (throw key #t))
- (lambda () (throw key #f))))
- (lambda (key arg) arg)))))
- `(,while-helper (,lambda (break continue)
- (do ()
- ((,not ,cond))
- ,@body)
- #t)))
+ (let ((key (make-symbol "while-key")))
+ `(do ()
+ ((catch ',key
+ (lambda ()
+ (let ((break (lambda () (throw ',key #t)))
+ (continue (lambda () (throw ',key #f))))
+ (do ()
+ ((not ,cond))
+ ,@body)
+ #t))
+ (lambda (key arg)
+ arg))))))
\f
;; Return a list of expressions that evaluate to the appropriate
;; arguments for resolve-interface according to SPEC.
+(eval-case
+ ((compile-toplevel)
+ (if (memq 'prefix (read-options))
+ (error "boot-9 must be compiled with #:kw, not :kw"))))
+
(define (compile-interface-spec spec)
(define (make-keyarg sym key quote?)
(cond ((or (memq sym spec)
(defmacro define-module args
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(let ((m (process-define-module
(list ,@(compile-define-module-args args)))))
(set-current-module m)
(defmacro use-modules modules
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(process-use-modules
(list ,@(map (lambda (m)
`(list ,@(compile-interface-spec m)))
(defmacro use-syntax (spec)
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
,@(if (pair? spec)
`((process-use-modules (list
(list ,@(compile-interface-spec spec))))
(let ((name (defined-name (car args))))
`(begin
(define-private ,@args)
- (eval-case ((load-toplevel) (export ,name))))))))
+ (eval-case ((load-toplevel compile-toplevel) (export ,name))))))))
(defmacro defmacro-public args
(define (syntax)
(#t
(let ((name (defined-name (car args))))
`(begin
- (eval-case ((load-toplevel) (export-syntax ,name)))
+ (eval-case ((load-toplevel compile-toplevel) (export-syntax ,name)))
(defmacro ,@args))))))
;; Export a local variable
(defmacro export names
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(call-with-deferred-observers
(lambda ()
(module-export! (current-module) ',names))))
(defmacro re-export names
`(eval-case
- ((load-toplevel)
+ ((load-toplevel compile-toplevel)
(call-with-deferred-observers
(lambda ()
(module-re-export! (current-module) ',names))))
;; Indeed, all references to global variables are memoized into such
;; variable objects.
+;; FIXME: these don't work with the compiler
(define-macro (@ mod-name var-name)
(let ((var (module-variable (resolve-interface mod-name) var-name)))
(if (not var)
#f))
(define (warn module name int1 val1 int2 val2 var val)
- (format #t
+ (format (current-error-port)
"WARNING: ~A: `~A' imported from both ~A and ~A\n"
(module-name module)
name
(define (warn-override-core module name int1 val1 int2 val2 var val)
(and (eq? int1 the-scm-module)
(begin
- (format #t
+ (format (current-error-port)
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
(module-name module)
(module-name int2)
;; 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")
;; the protected thunk.
(lambda ()
- (let ((status (scm-style-repl)))
+ (let ((status (start-repl 'scheme)))
(run-hook exit-hook)
status))
(provided? sym)))
(begin-deprecated
- (primitive-load-path "ice-9/deprecated.scm"))
+ (primitive-load-path "ice-9/deprecated"))
\f
HCoop / bpt / guile.git / blobdiff