Replace eval-case with eval-when

* module/ice-9/boot-9.scm (eval-when): Replace eval-case with eval-when.
  Eval-when is *much* simpler, and more expressive to boot. Perhaps in
  the future we'll get 'visit and 'revisit too.

* module/ice-9/deprecated.scm (eval-case): Provide mostly-working
  deprecated version of eval-case.

* module/ice-9/boot-9.scm (defmacro, define-macro): Relax condition: we
  can make defmacros that are not at the toplevel now. But in the future
  we should replace this implementation of defmacros with one written in
  syntax-case.
  (define-module, use-modules, use-syntax): Allow at non-toplevel.
  (define-public, defmacro-public, export, re-export): Don't evaluate at
  compile-time, I can't see how that helps things. Allow `export' and
  `re-export' at non-toplevel.

* module/ice-9/getopt-long.scm:
* module/ice-9/i18n.scm:
* module/oop/goops.scm:
* module/oop/goops/compile.scm:
* module/oop/goops/dispatch.scm: Switch to use eval-when, not
  eval-case.

* module/language/scheme/compile-ghil.scm (eval-when): Replace eval-case
  transformer with eval-when transformer. Sooooo much simpler, and it
  will get better once we separate expansion from compilation.

* module/language/scheme/expand.scm (quasiquote): Hm, expand quasiquote
  properly. Not hygienic. Syncase needed.
  (lambda): Handle internal defines with docstrings propertly.

module/ice-9/boot-9.scm

@@ -86,42 +86,29 @@
 
 
 
-;;; {EVAL-CASE}
+;; (eval-when (situation...) form...)
-;;;
-
-;; (eval-case ((situation*) forms)* (else forms)?)
 ;;
-;; Evaluate certain code based on the situation that eval-case is used
+;; Evaluate certain code based on the situation that eval-when is used
-;; in. There are three situations defined. `load-toplevel' triggers for
+;; in. There are three situations defined.
-;; code evaluated at the top-level, for example from the REPL or when
+;;
-;; loading a file. `compile-toplevel' triggers for code compiled at the
+;; `load' triggers when a file is loaded via `load', or when a compiled
-;; toplevel. `execute' triggers during execution of code not at the top
+;; file is loaded.
-;; level.
+;;
+;; `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)
+     (let ((situations (cadr exp))
-       (or (not (pair? env)) (not (pair? (car env)))))
+           (body (cddr exp)))
-     (define (syntax)
+       (if (or (memq 'load situations)
-       (error "syntax error in eval-case"))
+               (memq 'eval situations))
-     (let loop ((clauses (cdr exp)))
+           `(begin . ,body))))))
-       (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))))))))
 
 
 
@@ -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
+(eval-when
- ((compile-toplevel)
+ ((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
+	      `(eval-when
-                ((load-toplevel compile-toplevel)
+                (eval load compile)
-                 (define ,name (defmacro:transformer ,transformer)))
+                (define ,name (defmacro:transformer ,transformer)))))))
-		(else
-		 (error "defmacro can only be used at the top level")))))))
     (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
+    `(eval-when
-      ((load-toplevel compile-toplevel)
+      (eval load compile)
-       (define ,name (defmacro:transformer ,transformer)))
+      (define ,name (defmacro:transformer ,transformer)))))
-      (else
-       (error "define-macro can only be used at the top level")))))
 
 
 
@@ -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
+(eval-when
- ((compile-toplevel)
+ ((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
+  `(eval-when
-    ((load-toplevel compile-toplevel)
+    (eval load compile)
-     (let ((m (process-define-module
+    (let ((m (process-define-module
-	       (list ,@(compile-define-module-args args)))))
+              (list ,@(compile-define-module-args args)))))
-       (set-current-module m)
+      (set-current-module m)
-       m))
+      m)))
-    (else
-     (error "define-module can only be used at the top level"))))
 
 ;; 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
+  `(eval-when
-    ((load-toplevel compile-toplevel)
+    (eval load compile)
-     (process-use-modules
+    (process-use-modules
-      (list ,@(map (lambda (m)
+     (list ,@(map (lambda (m)
-		     `(list ,@(compile-interface-spec m)))
+                    `(list ,@(compile-interface-spec m)))
-		   modules)))
+                  modules)))
-     *unspecified*)
+    *unspecified*))
-    (else
-     (error "use-modules can only be used at the top level"))))
 
 (defmacro use-syntax (spec)
-  `(eval-case
+  `(eval-when
-    ((load-toplevel compile-toplevel)
+    (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*)
+     *unspecified*))
-    (else
-     (error "use-syntax can only be used at the top level"))))
 
 ;; 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
+  `(call-with-deferred-observers
-    ((load-toplevel compile-toplevel)
+    (lambda ()
-     (call-with-deferred-observers
+      (module-export! (current-module) ',names))))
-      (lambda ()
-	(module-export! (current-module) ',names))))
-    (else
-     (error "export can only be used at the top level"))))
 
 (defmacro re-export names
-  `(eval-case
+  `(call-with-deferred-observers
-    ((load-toplevel compile-toplevel)
+    (lambda ()
-     (call-with-deferred-observers
+      (module-re-export! (current-module) ',names))))
-      (lambda ()
-	(module-re-export! (current-module) ',names))))
-    (else
-     (error "re-export can only be used at the top level"))))
 
 (defmacro export-syntax names
   `(export ,@names))

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))))

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
+(eval-when (eval load compile)
- ((load-toplevel compile-toplevel)
-
   ;; This binding is used both at compile-time and run-time.
-
   (define option-spec-fields '(name
-			       value
+                               value
-			       required?
+                               required?
-			       single-char
+                               single-char
-			       predicate
+                               predicate
-			       value-policy))))
+                               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
+(eval-when (eval load compile)
- ((load-toplevel compile-toplevel)
-
   ;; 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
+    `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
-       (record-modifier option-spec ',field)))))
+       (record-modifier option-spec ',field))))
 
 (defmacro define-all-option-spec-accessors/modifiers ()
   `(begin

module/ice-9/i18n.scm

@@ -83,9 +83,8 @@
            locale-yes-regexp locale-no-regexp))
 
 
-(eval-case
+(eval-when (eval load compile)
- ((load-toplevel compile-toplevel)
+  (load-extension "libguile-i18n-v-0" "scm_init_i18n"))
-  (load-extension "libguile-i18n-v-0" "scm_init_i18n")))
 
 
 ;;;

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
+(define-scheme-translator eval-when
-  (,clauses
+  ((,when . ,body) (guard (list? when) (and-map symbol? when))
-   (retrans
+   (if (memq 'compile when)
-    `(begin
+       (primitive-eval `(begin . ,body)))
-       ;; Compilation of toplevel units is always wrapped in a lambda
+   (if (memq 'load when)
-       ,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e))))
+       (retrans `(begin . ,body))
-           (let loop ((seen '()) (in clauses) (runtime '()))
+       (retrans `(begin)))))
-             (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 apply
   ;; FIXME: not hygienic, relies on @apply not being shadowed

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))))))
 

module/oop/goops.scm

@@ -78,9 +78,8 @@
 (define *goops-module* (current-module))
 
 ;; First initialize the builtin part of GOOPS
-(eval-case
+(eval-when (eval load compile)
- ((load-toplevel compile-toplevel)
+  (%init-goops-builtins))
-  (%init-goops-builtins)))
 
 ;; Then load the rest of GOOPS
 (use-modules (oop goops util)
@@ -88,10 +87,9 @@
 	     (oop goops compile))
 
 
-(eval-case
+(eval-when (eval load compile)
- ((load-toplevel compile-toplevel)
   (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
+(eval-when (compile)
- ((compile-toplevel)
   (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
+(eval-when (eval load compile)
- ((load-toplevel compile-toplevel)
+  (define num-standard-pre-cache 20))
-  (define num-standard-pre-cache 20)))
 
 (define-macro (define-standard-accessor-method form . body)
   (let ((name (caar form))

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)

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)