diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 542238589..5d5c7f3e3 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -86,42 +86,29 @@ -;;; {EVAL-CASE} -;;; - -;; (eval-case ((situation*) forms)* (else forms)?) +;; (eval-when (situation...) form...) ;; -;; Evaluate certain code based on the situation that eval-case is used -;; 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. +;; Evaluate certain code based on the situation that eval-when is used +;; in. There are three situations defined. +;; +;; `load' triggers when a file is loaded via `load', or when a compiled +;; file is loaded. +;; +;; `compile' triggers when an expression is compiled. +;; +;; `eval' triggers when code is evaluated interactively, as at the REPL +;; or via the `compile' or `eval' procedures. -(define eval-case +;; NB: this macro is only ever expanded by the interpreter. The compiler +;; notices it and interprets the situations differently. +(define eval-when (procedure->memoizing-macro (lambda (exp env) - (define (toplevel-env? env) - (or (not (pair? env)) (not (pair? (car env))))) - (define (syntax) - (error "syntax error in eval-case")) - (let loop ((clauses (cdr exp))) - (cond - ((null? clauses) - #f) - ((not (list? (car clauses))) - (syntax)) - ((eq? 'else (caar clauses)) - (or (null? (cdr clauses)) - (syntax)) - (cons 'begin (cdar clauses))) - ((not (list? (caar clauses))) - (syntax)) - ((and (toplevel-env? env) - (memq 'load-toplevel (caar clauses))) - (cons 'begin (cdar clauses))) - (else - (loop (cdr clauses)))))))) + (let ((situations (cadr exp)) + (body (cddr exp))) + (if (or (memq 'load situations) + (memq 'eval situations)) + `(begin . ,body)))))) @@ -129,8 +116,8 @@ ;; module, the primary location of those symbols, rather than in ;; (guile-user), the default module that we compile in. -(eval-case - ((compile-toplevel) +(eval-when + ((compile) (set-current-module (resolve-module '(guile))))) ;;; {Defmacros} @@ -160,11 +147,9 @@ (let ((defmacro-transformer (lambda (name parms . body) (let ((transformer `(lambda ,parms ,@body))) - `(eval-case - ((load-toplevel compile-toplevel) - (define ,name (defmacro:transformer ,transformer))) - (else - (error "defmacro can only be used at the top level"))))))) + `(eval-when + (eval load compile) + (define ,name (defmacro:transformer ,transformer))))))) (defmacro:transformer defmacro-transformer))) @@ -2707,11 +2692,9 @@ module '(ice-9 q) '(make-q q-length))}." (if (symbol? first) (car rest) `(lambda ,(cdr first) ,@rest)))) - `(eval-case - ((load-toplevel compile-toplevel) - (define ,name (defmacro:transformer ,transformer))) - (else - (error "define-macro can only be used at the top level"))))) + `(eval-when + (eval load compile) + (define ,name (defmacro:transformer ,transformer))))) @@ -2753,8 +2736,8 @@ 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-case - ((compile-toplevel) +(eval-when + ((compile) (if (memq 'prefix (read-options)) (error "boot-9 must be compiled with #:kw, not :kw")))) @@ -2821,14 +2804,12 @@ module '(ice-9 q) '(make-q q-length))}." (cddr args)))))) (defmacro define-module args - `(eval-case - ((load-toplevel compile-toplevel) - (let ((m (process-define-module - (list ,@(compile-define-module-args args))))) - (set-current-module m) - m)) - (else - (error "define-module can only be used at the top level")))) + `(eval-when + (eval load compile) + (let ((m (process-define-module + (list ,@(compile-define-module-args args))))) + (set-current-module m) + m))) ;; The guts of the use-modules macro. Add the interfaces of the named ;; modules to the use-list of the current module, in order. @@ -2846,28 +2827,24 @@ module '(ice-9 q) '(make-q q-length))}." (module-use-interfaces! (current-module) interfaces))))) (defmacro use-modules modules - `(eval-case - ((load-toplevel compile-toplevel) - (process-use-modules - (list ,@(map (lambda (m) - `(list ,@(compile-interface-spec m))) - modules))) - *unspecified*) - (else - (error "use-modules can only be used at the top level")))) + `(eval-when + (eval load compile) + (process-use-modules + (list ,@(map (lambda (m) + `(list ,@(compile-interface-spec m))) + modules))) + *unspecified*)) (defmacro use-syntax (spec) - `(eval-case - ((load-toplevel compile-toplevel) + `(eval-when + (eval load compile) ,@(if (pair? spec) `((process-use-modules (list (list ,@(compile-interface-spec spec)))) (set-module-transformer! (current-module) ,(car (last-pair spec)))) `((set-module-transformer! (current-module) ,spec))) - *unspecified*) - (else - (error "use-syntax can only be used at the top level")))) + *unspecified*)) ;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed ;; as soon as guile supports hygienic macros. @@ -2888,7 +2865,7 @@ module '(ice-9 q) '(make-q q-length))}." (let ((name (defined-name (car args)))) `(begin (define-private ,@args) - (eval-case ((load-toplevel compile-toplevel) (export ,name)))))))) + (export ,name)))))) (defmacro defmacro-public args (define (syntax) @@ -2903,7 +2880,7 @@ module '(ice-9 q) '(make-q q-length))}." (#t (let ((name (defined-name (car args)))) `(begin - (eval-case ((load-toplevel compile-toplevel) (export-syntax ,name))) + (export-syntax ,name) (defmacro ,@args)))))) ;; Export a local variable @@ -2941,22 +2918,14 @@ module '(ice-9 q) '(make-q q-length))}." names))) (defmacro export names - `(eval-case - ((load-toplevel compile-toplevel) - (call-with-deferred-observers - (lambda () - (module-export! (current-module) ',names)))) - (else - (error "export can only be used at the top level")))) + `(call-with-deferred-observers + (lambda () + (module-export! (current-module) ',names)))) (defmacro re-export names - `(eval-case - ((load-toplevel compile-toplevel) - (call-with-deferred-observers - (lambda () - (module-re-export! (current-module) ',names)))) - (else - (error "re-export can only be used at the top level")))) + `(call-with-deferred-observers + (lambda () + (module-re-export! (current-module) ',names)))) (defmacro export-syntax names `(export ,@names)) diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 91f4d7445..f3b7cafe4 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -178,3 +178,20 @@ (define (list->uniform-vector prot lst) (list->uniform-array 1 prot lst)) + +(define-macro (eval-case . clauses) + (issue-deprecation-warning + "`eval-case' is deprecated. Use `eval-when' instead.") + ;; Practically speaking, eval-case only had load-toplevel and else as + ;; conditions. + (cond + ((assoc-ref clauses '(load-toplevel)) + => (lambda (exps) + ;; the *unspecified so that non-toplevel definitions will be + ;; caught + `(begin *unspecified* . ,exps))) + ((assoc-ref clauses 'else) + => (lambda (exps) + `(begin *unspecified* . ,exps))) + (else + `(begin)))) diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm index 70bf305ec..b16328ba8 100644 --- a/module/ice-9/getopt-long.scm +++ b/module/ice-9/getopt-long.scm @@ -160,34 +160,29 @@ :use-module ((ice-9 common-list) :select (some remove-if-not)) :export (getopt-long option-ref)) -(eval-case - ((load-toplevel compile-toplevel) - +(eval-when (eval load compile) ;; This binding is used both at compile-time and run-time. - (define option-spec-fields '(name - value - required? - single-char - predicate - value-policy)))) + value + required? + single-char + predicate + value-policy))) (define option-spec (make-record-type 'option-spec option-spec-fields)) (define make-option-spec (record-constructor option-spec option-spec-fields)) -(eval-case - ((load-toplevel compile-toplevel) - +(eval-when (eval load compile) ;; The following procedures are used only at compile-time when expanding ;; `define-all-option-spec-accessors/modifiers' (see below). (define (define-one-option-spec-field-accessor field) - `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat + `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat (record-accessor option-spec ',field))) (define (define-one-option-spec-field-modifier field) - `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat - (record-modifier option-spec ',field))))) + `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat + (record-modifier option-spec ',field)))) (defmacro define-all-option-spec-accessors/modifiers () `(begin diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 2a8e7414c..f33a9f258 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -83,9 +83,8 @@ locale-yes-regexp locale-no-regexp)) -(eval-case - ((load-toplevel compile-toplevel) - (load-extension "libguile-i18n-v-0" "scm_init_i18n"))) +(eval-when (eval load compile) + (load-extension "libguile-i18n-v-0" "scm_init_i18n")) ;;; diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index db3628366..587a173fe 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -351,36 +351,13 @@ (-> (ref (ghil-var-at-module! e modname sym #f))))) (define *the-compile-toplevel-symbol* 'compile-toplevel) -(define-scheme-translator eval-case - (,clauses - (retrans - `(begin - ;; Compilation of toplevel units is always wrapped in a lambda - ,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e)))) - (let loop ((seen '()) (in clauses) (runtime '())) - (cond - ((null? in) runtime) - (else - (pmatch (car in) - ((else . ,body) - (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen))) - (primitive-eval `(begin ,@body))) - (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen) - runtime - body)) - ((,keys . ,body) (guard (list? keys) (and-map symbol? keys)) - (for-each (lambda (k) - (if (memq k seen) - (syntax-error l "eval-case condition seen twice" k))) - keys) - (if (and toplevel? (memq *the-compile-toplevel-symbol* keys)) - (primitive-eval `(begin ,@body))) - (loop (append keys seen) - (cdr in) - (if (memq (if toplevel? 'load-toplevel 'evaluate) keys) - (append runtime body) - runtime))) - (else (syntax-error l "bad eval-case clause" (car in)))))))))))) +(define-scheme-translator eval-when + ((,when . ,body) (guard (list? when) (and-map symbol? when)) + (if (memq 'compile when) + (primitive-eval `(begin . ,body))) + (if (memq 'load when) + (retrans `(begin . ,body)) + (retrans `(begin))))) (define-scheme-translator apply ;; FIXME: not hygienic, relies on @apply not being shadowed diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm index 21a2d2876..d0e66e9ad 100644 --- a/module/language/scheme/expand.scm +++ b/module/language/scheme/expand.scm @@ -118,7 +118,8 @@ (-> `(,'quasiquote ,(let lp ((x obj) (level 0)) (cond ((not (apair? x)) x) - ((memq (acar x) '(,'unquote ,'unquote-splicing)) + ;; FIXME: hygiene regarding imported , / ,@ rebinding + ((memq (acar x) '(unquote unquote-splicing)) (amatch (acdr x) ((,obj) (cond @@ -264,6 +265,9 @@ (define-scheme-expander lambda ;; (lambda FORMALS BODY...) + ((,formals ,docstring ,body1 . ,body) (guard (string? docstring)) + (-> `(lambda ,formals ,docstring ,(expand-internal-defines + (map re-expand (cons body1 body)))))) ((,formals . ,body) (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body)))))) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index d9a83b8d4..429a32822 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -78,9 +78,8 @@ (define *goops-module* (current-module)) ;; First initialize the builtin part of GOOPS -(eval-case - ((load-toplevel compile-toplevel) - (%init-goops-builtins))) +(eval-when (eval load compile) + (%init-goops-builtins)) ;; Then load the rest of GOOPS (use-modules (oop goops util) @@ -88,10 +87,9 @@ (oop goops compile)) -(eval-case - ((load-toplevel compile-toplevel) +(eval-when (eval load compile) (define min-fixnum (- (expt 2 29))) - (define max-fixnum (- (expt 2 29) 1)))) + (define max-fixnum (- (expt 2 29) 1))) ;; ;; goops-error @@ -1039,8 +1037,7 @@ ;; the idea is to compile the index into the procedure, for fastest ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. -(eval-case - ((compile-toplevel) +(eval-when (compile) (use-modules ((language scheme compile-ghil) :select (define-scheme-translator)) ((language ghil) :select (make-ghil-inline make-ghil-call)) (system base pmatch)) @@ -1061,11 +1058,10 @@ (make-ghil-inline #f #f 'slot-set (list (retrans obj) (retrans index) (retrans val)))) (else - (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))) + (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))) -(eval-case - ((load-toplevel compile-toplevel) - (define num-standard-pre-cache 20))) +(eval-when (eval load compile) + (define num-standard-pre-cache 20)) (define-macro (define-standard-accessor-method form . body) (let ((name (caar form)) diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm index 22741de40..3962be4bc 100644 --- a/module/oop/goops/compile.scm +++ b/module/oop/goops/compile.scm @@ -19,7 +19,7 @@ ;; There are circularities here; you can't import (oop goops compile) ;; before (oop goops). So when compiling, make sure that things are ;; kosher. -(eval-case ((compile-toplevel) (resolve-module '(oop goops)))) +(eval-when (compile) (resolve-module '(oop goops))) (define-module (oop goops compile) :use-module (oop goops) diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index d9a48dde7..93fdf98af 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -19,7 +19,7 @@ ;; There are circularities here; you can't import (oop goops compile) ;; before (oop goops). So when compiling, make sure that things are ;; kosher. -(eval-case ((compile-toplevel) (resolve-module '(oop goops)))) +(eval-when (compile) (resolve-module '(oop goops))) (define-module (oop goops dispatch) :use-module (oop goops)