all of guile compiles now, expanded with syncase

* libguile/eval.c (scm_m_eval_when): Whoops, eval-when has an implicit
  begin. Fix.

* module/oop/goops.scm: Syncase doesn't like definitions in expression
  context, and grudgingly I have decided to go along with that. But that
  doesn't mean we can't keep the old semantics, via accessing the module
  system directly. So do so. I took the opportunity to rewrite some
  macros with syntax-rules and syntax-case -- the former is nicer than
  the latter, of course.

* module/oop/goops/save.scm: Don't define within an expression.

* module/oop/goops/simple.scm (define-class): Use define-syntax.

* module/oop/goops/stklos.scm (define-class): Use define-syntax.

libguile/eval.c

@@ -2149,12 +2149,12 @@ SCM_SYMBOL (sym_load, "load");
 SCM 
 scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
 {
-  ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+  ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
   ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
 
   if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr)))
       || scm_is_true (scm_memq (sym_load, scm_cadr (expr))))
-    return scm_caddr (expr);
+    return scm_cons (SCM_IM_BEGIN, scm_cddr (expr));
   
   return scm_list_1 (SCM_IM_BEGIN);
 }

module/oop/goops.scm

@@ -154,17 +154,6 @@
 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 ;;;   OPTION ::= KEYWORD VALUE
 ;;;
-(define (define-class-pre-definition kw val)
-  (case kw
-    ((#:getter #:setter)
-     `(if (or (not (defined? ',val))
-              (not (is-a? ,val <generic>)))
-          (define-generic ,val)))
-    ((#:accessor)
-     `(if (or (not (defined? ',val))
-              (not (is-a? ,val <accessor>)))
-          (define-accessor ,val)))
-    (else #f)))
 
 (define (kw-do-map mapper f kwargs)
   (define (keywords l)
@@ -180,71 +169,6 @@
          (a (args kwargs)))
     (mapper f k a)))
 
-;;; This code should be implemented in C.
-;;;
-(define-macro (define-class name supers . slots)
-  ;; Some slot options require extra definitions to be made. In
-  ;; particular, we want to make sure that the generic function objects
-  ;; which represent accessors exist before `make-class' tries to add
-  ;; methods to them.
-  ;;
-  ;; Postpone some error handling to class macro.
-  ;;
-  `(begin
-     ;; define accessors
-     ,@(append-map (lambda (slot)
-                     (kw-do-map filter-map
-                                define-class-pre-definition 
-                                (if (pair? slot) (cdr slot) '())))
-                   (take-while (lambda (x) (not (keyword? x))) slots))
-     (if (and (defined? ',name)
-              (is-a? ,name <class>)
-              (memq <object> (class-precedence-list ,name)))
-         (class-redefinition ,name
-                             (class ,supers ,@slots #:name ',name))
-         (define ,name (class ,supers ,@slots #:name ',name)))))
-
-(define-syntax standard-define-class
-  (syntax-rules ()
-    ((_ arg ...) (define-class arg ...))))
-
-;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
-;;;
-;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
-;;;   OPTION ::= KEYWORD VALUE
-;;;
-(define-macro (class supers . slots)
-  (define (make-slot-definition-forms slots)
-    (map
-     (lambda (def)
-       (cond
-        ((pair? def)
-         `(list ',(car def)
-                ,@(kw-do-map append-map
-                             (lambda (kw arg)
-                               (case kw
-                                 ((#:init-form)
-                                  `(#:init-form ',arg
-                                    #:init-thunk (lambda () ,arg)))
-                                 (else (list kw arg))))
-                             (cdr def))))
-        (else
-         `(list ',def))))
-     slots))
-    
-  (if (not (list? supers))
-      (goops-error "malformed superclass list: ~S" supers))
-  (let ((slot-defs (cons #f '()))
-        (slots (take-while (lambda (x) (not (keyword? x))) slots))
-        (options (or (find-tail keyword? slots) '())))
-    `(make-class
-      ;; evaluate super class variables
-      (list ,@supers)
-      ;; evaluate slot definitions, except the slot name!
-      (list ,@(make-slot-definition-forms slots))
-      ;; evaluate class options
-      ,@options)))
-
 (define (make-class supers slots . options)
   (let ((env (or (get-keyword #:environment options #f)
 		 (top-level-env))))
@@ -277,6 +201,108 @@
 	     #:environment env
 	     options))))
 
+;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
+;;;
+;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
+;;;   OPTION ::= KEYWORD VALUE
+;;;
+(define-macro (class supers . slots)
+  (define (make-slot-definition-forms slots)
+    (map
+     (lambda (def)
+       (cond
+        ((pair? def)
+         `(list ',(car def)
+                ,@(kw-do-map append-map
+                             (lambda (kw arg)
+                               (case kw
+                                 ((#:init-form)
+                                  `(#:init-form ',arg
+                                    #:init-thunk (lambda () ,arg)))
+                                 (else (list kw arg))))
+                             (cdr def))))
+        (else
+         `(list ',def))))
+     slots))
+  (if (not (list? supers))
+      (goops-error "malformed superclass list: ~S" supers))
+  (let ((slot-defs (cons #f '()))
+        (slots (take-while (lambda (x) (not (keyword? x))) slots))
+        (options (or (find-tail keyword? slots) '())))
+    `(make-class
+      ;; evaluate super class variables
+      (list ,@supers)
+      ;; evaluate slot definitions, except the slot name!
+      (list ,@(make-slot-definition-forms slots))
+      ;; evaluate class options
+      ,@options)))
+
+(define-syntax define-class-pre-definition
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (k arg rest ...) out ...)
+       (keyword? (syntax-object->datum (syntax k)))
+       (case (syntax-object->datum (syntax k))
+         ((#:getter #:setter)
+          (syntax
+           (define-class-pre-definition (rest ...)
+             out ...
+             (if (or (not (defined? 'arg))
+                     (not (is-a? arg <generic>)))
+                 (toplevel-define!
+                  'arg
+                  (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+         ((#:accessor)
+          (syntax
+           (define-class-pre-definition (rest ...)
+             out ...
+             (if (or (not (defined? 'arg))
+                     (not (is-a? arg <accessor>)))
+                 (toplevel-define!
+                  'arg
+                  (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+         (else
+          (syntax
+           (define-class-pre-definition (rest ...) out ...)))))
+      ((_ () out ...)
+       (syntax (begin out ...))))))
+       
+;; Some slot options require extra definitions to be made. In
+;; particular, we want to make sure that the generic function objects
+;; which represent accessors exist before `make-class' tries to add
+;; methods to them.
+(define-syntax define-class-pre-definitions
+  (lambda (x)
+    (syntax-case x ()
+      ((_ () out ...)
+       (syntax (begin out ...)))
+      ((_ (slot rest ...) out ...)
+       (keyword? (syntax-object->datum (syntax slot)))
+       (syntax (begin out ...)))
+      ((_ (slot rest ...) out ...)
+       (identifier? (syntax slot))
+       (syntax (define-class-pre-definitions (rest ...)
+                 out ...)))
+      ((_ ((slotname slotopt ...) rest ...) out ...)
+       (syntax (define-class-pre-definitions (rest ...) 
+                 out ... (define-class-pre-definition (slotopt ...))))))))
+
+(define-syntax define-class
+  (syntax-rules ()
+    ((_ name supers slot ...)
+     (begin
+       (define-class-pre-definitions (slot ...))
+       (if (and (defined? 'name)
+                (is-a? name <class>)
+                (memq <object> (class-precedence-list name)))
+           (class-redefinition name
+                               (class supers slot ... #:name 'name))
+           (toplevel-define! 'name (class supers slot ... #:name 'name)))))))
+       
+(define-syntax standard-define-class
+  (syntax-rules ()
+    ((_ arg ...) (define-class arg ...))))
+
 ;;;
 ;;; {Generic functions and accessors}
 ;;;
@@ -1035,11 +1061,14 @@
 ;; the idea is to compile the index into the procedure, for fastest
 ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
 
+;; separate expression so that we affect the expansion of the subsequent
+;; expression
 (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))
+               (system base pmatch)))
 
+(eval-when (compile)
   ;; unfortunately, can't use define-inline because these are primitive
   ;; syntaxen.
   (define-scheme-translator @slot-ref

module/oop/goops/save.scm

@@ -110,9 +110,7 @@
 ;;; Readables
 ;;;
 
-(if (or (not (defined? 'readables))
+(define readables (make-weak-key-hash-table 61))
-	(not readables))
-    (define readables (make-weak-key-hash-table 61)))
 
 (define-macro (readable exp)
   `(make-readable ,exp ',(copy-tree exp)))

module/oop/goops/simple.scm

@@ -23,6 +23,9 @@
   :export (define-class)
   :no-backtrace)
 
-(define define-class define-class-with-accessors-keywords)
+(define-syntax define-class
+  (syntax-rules ()
+    ((_ arg ...)
+     (define-class-with-accessors-keywords arg ...))))
 
 (module-use! %module-public-interface (resolve-interface '(oop goops)))

module/oop/goops/stklos.scm

@@ -47,51 +47,30 @@
 ;;; Enable keyword support (*fixme*---currently this has global effect)
 (read-set! keywords 'prefix)
 
-(define standard-define-class-transformer
+(define-syntax define-class
-  (macro-transformer standard-define-class))
+  (syntax-rules ()
+    ((_ name supers (slot ...) rest ...)
+     (standard-define-class name supers slot ... rest ...))))
 
-(define define-class
+(define (toplevel-define! name val)
-  ;; Syntax
+  (module-define! (current-module) name val))
-  (let ((name cadr)
-	(supers caddr)
-	(slots cadddr)
-	(rest cddddr))
-    (procedure->memoizing-macro
-      (lambda (exp env)
-	(standard-define-class-transformer
-	 `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
-	    ,@(rest exp))
-	 env)))))
 
-(define define-method
+(define-syntax define-method
-  (procedure->memoizing-macro
+  (syntax-rules (setter)
-    (lambda (exp env)
+    ((_ (setter name) rest ...)
-      (let ((name (cadr exp)))
+     (begin
-	(if (and (pair? name)
+       (if (or (not (defined? 'name))
-		 (eq? (car name) 'setter)
+               (not (is-a? name <generic-with-setter>)))
-		 (pair? (cdr name))
+           (toplevel-define! 'name
-		 (null? (cddr name)))
+                             (ensure-accessor
-	    (let ((name (cadr name)))
+                              (if (defined? 'name) name #f) 'name)))
-	      (cond ((not (symbol? name))
+       (add-method! (setter name) (method rest ...))))
-		     (goops-error "bad method name: ~S" name))
+    ((_ name rest ...)
-		    ((defined? name env)
+     (begin
-		     `(begin
+       (if (or (not (defined? 'name))
-			(if (not (is-a? ,name <generic-with-setter>))
+               (not (or (is-a? name <generic>)
-			    (define-accessor ,name))
+                        (is-a? name <primitive-generic>))))
-			(add-method! (setter ,name) (method ,@(cddr exp)))))
+           (toplevel-define! 'name
-		    (else
+                             (ensure-generic
-		     `(begin
+                              (if (defined? 'name) name #f) 'name)))
-			(define-accessor ,name)
+       (add-method! name (method rest ...))))))
-			(add-method! (setter ,name) (method ,@(cddr exp)))))))
-	    (cond ((not (symbol? name))
-		   (goops-error "bad method name: ~S" name))
-		  ((defined? name env)
-		   `(begin
-		      (if (not (or (is-a? ,name <generic>)
-				   (is-a? ,name <primitive-generic>)))
-			  (define-generic ,name))
-		      (add-method! ,name (method ,@(cddr exp)))))
-		  (else
-		   `(begin
-		      (define-generic ,name)
-		      (add-method! ,name (method ,@(cddr exp)))))))))))