make define-class' and class' into defmacros

* oop/goops.scm: Use srfi-1, as util.scm already does.
  (kw-do-map): New helper for processing keyword args.
  (define-class-pre-definition, define-class): Rework so that
  define-class is a defmacro without side effects. There are two
  functional differences: we don't check that define-class is called only
  at the toplevel, because defining a lexical class might makes sense,
  and defmacros don't give us the toplevel check that we would want.
  Second in the redefinition case, we don't do a `define', as we don't
  actually need a new variable.
  (class): Similarly, make `class' a defmacro.

oop/goops.scm

@@ -26,6 +26,7 @@
 ;;;;
 
 (define-module (oop goops)
+  :use-module (srfi srfi-1)
   :export-syntax (define-class class standard-define-class
 		  define-generic define-accessor define-method
 		  define-extended-generic define-extended-generics
@@ -157,94 +158,55 @@
 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 ;;;   OPTION ::= KEYWORD VALUE
 ;;;
-(define (define-class-pre-definition keyword exp env)
+(define (define-class-pre-definition kw val)
-  (case keyword
+  (case kw
     ((#:getter #:setter)
-     `(process-class-pre-define-generic ',exp))
+     `(if (or (not (defined? ',val))
+              (not (is-a? ,val <generic>)))
+          (define-generic ,val)))
     ((#:accessor)
-     `(process-class-pre-define-accessor ',exp))
+     `(if (or (not (defined? ',val))
+              (not (is-a? ,val <accessor>)))
+          (define-accessor ,val)))
     (else #f)))
 
-(define (process-class-pre-define-generic name)
+(define (kw-do-map mapper f kwargs)
-  (let ((var (module-variable (current-module) name)))
+  (define (keywords l)
-    (if (not (and var
+    (cond
-		  (variable-bound? var)
+     ((null? l) '())
-		  (is-a? (variable-ref var) <generic>)))
+     ((or (null? (cdr l)) (not (keyword? (car l))))
-	(process-define-generic name))))
+      (goops-error "malformed keyword arguments: ~a" kwargs))
-
+     (else (cons (car l) (keywords (cddr l))))))
-(define (process-class-pre-define-accessor name)
+  (define (args l)
-  (let ((var (module-variable (current-module) name)))
+    (if (null? l) '() (cons (cadr l) (args (cddr l)))))
-    (cond ((or (not var)
+  ;; let* to check keywords first
-	       (not (variable-bound? var)))
+  (let* ((k (keywords kwargs))
-	   (process-define-accessor name))
+         (a (args kwargs)))
-	  ((or (is-a? (variable-ref var) <accessor>)
+    (mapper f k a)))
-	       (is-a? (variable-ref var) <extended-generic-with-setter>)))
-	  ((is-a? (variable-ref var) <generic>)
-	   ;;*fixme* don't mutate an imported object!
-	   (variable-set! var (ensure-accessor (variable-ref var) name)))
-	  (else
-	   (process-define-accessor name)))))
 
 ;;; This code should be implemented in C.
 ;;;
-(define define-class
+(define-macro (define-class name supers . slots)
-  (letrec (;; Some slot options require extra definitions to be made.
+  ;; Some slot options require extra definitions to be made. In
-	   ;; In particular, we want to make sure that the generic
+  ;; particular, we want to make sure that the generic function objects
-	   ;; function objects which represent accessors exist
+  ;; which represent accessors exist before `make-class' tries to add
-	   ;; before `make-class' tries to add methods to them.
+  ;; methods to them.
   ;;
-	   ;; Postpone error handling to class macro.
+  ;; Postpone some error handling to class macro.
   ;;
-	   (pre-definitions
-	    (lambda (slots env)
-	      (do ((slots slots (cdr slots))
-		   (definitions '()
-		     (if (pair? (car slots))
-			 (do ((options (cdar slots) (cddr options))
-			      (definitions definitions
-				(cond ((not (symbol? (cadr options)))
-				       definitions)
-				      ((define-class-pre-definition
-					 (car options)
-					 (cadr options)
-					 env)
-				       => (lambda (definition)
-					    (cons definition definitions)))
-				      (else definitions))))
-			     ((not (and (pair? options)
-					(pair? (cdr options))))
-			      definitions))
-			 definitions)))
-		  ((or (not (pair? slots))
-		       (keyword? (car slots)))
-		   (reverse definitions)))))
-	   
-	   ;; Syntax
-	   (name cadr)
-	   (slots cdddr))
-    
-    (procedure->memoizing-macro
-      (lambda (exp env)
-	(cond ((not (top-level-env? env))
-	       (goops-error "define-class: Only allowed at top level"))
-	      ((not (and (list? exp) (>= (length exp) 3)))
-	       (goops-error "missing or extra expression"))
-	      (else
-	       (let ((name (name exp)))
   `(begin
      ;; define accessors
-		    ,@(pre-definitions (slots exp) env)
+     ,@(append-map (lambda (slot)
-		    ;; update the current-module
+                     (kw-do-map filter-map
-		    (let* ((class (class ,@(cddr exp) #:name ',name))
+                                define-class-pre-definition 
-			   (var (module-ensure-local-variable!
+                                (if (pair? slot) (cdr slot) '())))
-				 (current-module) ',name))
+                   (take-while (lambda (x) (not (keyword? x))) slots))
-			   (old (and (variable-bound? var)
+     (if (and (defined? ',name)
-				     (variable-ref var))))
+              (is-a? ,name <class>)
-		      (if (and old
+              (memq <object> (class-precedence-list ,name)))
-			       (is-a? old <class>)
+         (class-redefinition ,name
-			       (memq <object> (class-precedence-list old)))
+                             (class ,supers ,@slots #:name ',name))
-			  (variable-set! var (class-redefinition old class))
+         (define ,name (class ,supers ,@slots #:name ',name)))))
-			  (variable-set! var class)))))))))))
 
 (define standard-define-class define-class)
 
@@ -253,69 +215,37 @@
 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 ;;;   OPTION ::= KEYWORD VALUE
 ;;;
-(define class
+(define-macro (class supers . slots)
-  (letrec ((slot-option-keyword car)
+  (define (make-slot-definition-forms slots)
-	   (slot-option-value cadr)
+    (map
-	   (process-slot-options
+     (lambda (def)
-	    (lambda (options)
+       (cond
-	      (let loop ((options options)
+        ((pair? def)
-			 (res '()))
+         `(list ',(car def)
-		(cond ((null? options)
+                ,@(kw-do-map append-map
-		       (reverse res))
+                             (lambda (kw arg)
-		      ((null? (cdr options))
+                               (case kw
-		       (goops-error "malformed slot option list"))
-		      ((not (keyword? (slot-option-keyword options)))
-		       (goops-error "malformed slot option list"))
-		      (else
-		       (case (slot-option-keyword options)
                                  ((#:init-form)
-			  (loop (cddr options)
+                                  `(#:init-form ',arg
-				(append (list `(lambda ()
+                                    #:init-thunk (lambda () ,arg)))
-						 ,(slot-option-value options))
+                                 (else (list kw arg))))
-					      #:init-thunk
+                             (cdr def))))
-					      (list 'quote
-						    (slot-option-value options))
-					      #:init-form)
-					res)))
         (else
-			  (loop (cddr options)
+         `(list ',def))))
-				(cons (cadr options)
+     slots))
-				      (cons (car options)
-					    res)))))))))))
     
-    (procedure->memoizing-macro
+  (if (not (list? supers))
-      (let ((supers cadr)
+      (goops-error "malformed superclass list: ~S" supers))
-	    (slots cddr)
+  (let ((slot-defs (cons #f '()))
-	    (options cdddr))
+        (slots (take-while (lambda (x) (not (keyword? x))) slots))
-	(lambda (exp env)
+        (options (or (find-tail keyword? slots) '())))
-	  (cond ((not (and (list? exp) (>= (length exp) 2)))
-		 (goops-error "missing or extra expression"))
-		((not (list? (supers exp)))
-		 (goops-error "malformed superclass list: ~S" (supers exp)))
-		(else
-		 (let ((slot-defs (cons #f '())))
-		   (do ((slots (slots exp) (cdr slots))
-			(defs slot-defs (cdr defs)))
-		       ((or (null? slots)
-			    (keyword? (car slots)))
     `(make-class
       ;; evaluate super class variables
-			  (list ,@(supers exp))
+      (list ,@supers)
       ;; evaluate slot definitions, except the slot name!
-			  (list ,@(cdr slot-defs))
+      (list ,@(make-slot-definition-forms slots))
       ;; evaluate class options
-			  ,@slots
+      ,@options)))
-			  ;; place option last in case someone wants to
-			  ;; pass a different value
-			  #:environment ',env))
-		     (set-cdr!
-		      defs
-		      (list (if (pair? (car slots))
-				`(list ',(slot-definition-name (car slots))
-				       ,@(process-slot-options
-					  (slot-definition-options
-					   (car slots))))
-				`(list ',(car slots))))))))))))))
 
 (define (make-class supers slots . options)
   (let ((env (or (get-keyword #:environment options #f)