generate the fixed-offset accessors at compile-time

* module/language/scheme/compile-ghil.scm (define-scheme-translator):
  Only add an else clause if the transformer didn't have one.

* module/oop/goops.scm (min-fixnum, max-fixnum): Define at compile-time
  as well.
  (@slot-ref, @slot-set!): Only define transformers for these at
  compile-time. Avoids loading up the compiler unnecessarily. Also, allow
  for the `n' to be determined lexically, in which case we dispatch to
  the primitive.
  (num-standard-pre-cache, define-standard-accessor-method)
  (bound-check-get, standard-get, standard-set): Rework the fixed-offset
  getters and setters so that they can be computed at compile-time.
  Accessors to fields with n > num-standard-pre-cache will be dispatched
  to the primitive instead of within the VM.

module/language/scheme/compile-ghil.scm

@@ -174,8 +174,9 @@
                  (define syntax-error (@ (system base compile) syntax-error))
                  (pmatch (cdr exp)
                          ,@clauses
-                         (else
+                         ,@(if (assq 'else clauses) '()
-                          (syntax-error l (format #f "bad ~A" ',sym) exp))))))
+                               '((else
+                                  (syntax-error l (format #f "bad ~A" ',sym) exp))))))))
 
 (define-scheme-translator quote
   ;; (quote OBJ)

module/oop/goops.scm

@@ -88,9 +88,10 @@
 	     (oop goops compile))
 
 
-(define min-fixnum (- (expt 2 29)))
+(eval-case
-
+ ((load-toplevel compile-toplevel)
-(define max-fixnum (- (expt 2 29) 1))
+  (define min-fixnum (- (expt 2 29)))
+  (define max-fixnum (- (expt 2 29) 1))))
 
 ;;
 ;; goops-error
@@ -1035,27 +1036,13 @@
 	   (procedure-environment proc)))
 	(lambda (o) (assert-bound (proc o) o)))))
 
-(define n-standard-accessor-methods 10)
-
-(define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
-(define standard-get-methods (make-vector n-standard-accessor-methods #f))
-(define standard-set-methods (make-vector n-standard-accessor-methods #f))
-
-(define (standard-accessor-method make methods)
-  (lambda (index)
-    (cond ((>= index n-standard-accessor-methods) (make index))
-	  ((vector-ref methods index))
-	  (else (let ((m (make index)))
-		  (vector-set! methods index m)
-		  m)))))
-
 ;; 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
- ((load-toplevel compile-toplevel)
+ ((compile-toplevel)
   (use-modules ((language scheme compile-ghil) :select (define-scheme-translator))
-               ((language ghil) :select (make-ghil-inline))
+               ((language ghil) :select (make-ghil-inline make-ghil-call))
                (system base pmatch))
 
   ;; unfortunately, can't use define-inline because these are primitive
@@ -1064,38 +1051,54 @@
     ((,obj ,index) (guard (integer? index)
                           (>= index 0) (< index max-fixnum))
      (make-ghil-inline #f #f 'slot-ref
-                       (list (retrans obj) (retrans index)))))
+                       (list (retrans obj) (retrans index))))
+    (else
+     (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))
 
   (define-scheme-translator @slot-set!
     ((,obj ,index ,val) (guard (integer? index)
                                (>= index 0) (< index max-fixnum))
      (make-ghil-inline #f #f 'slot-set
-                       (list (retrans obj) (retrans index) (retrans val)))))))
+                       (list (retrans obj) (retrans index) (retrans val))))
+    (else
+     (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))))
 
-;; Irritatingly, we can't use `compile' here, as the module shadows
+(eval-case
-;; the binding.
+ ((load-toplevel compile-toplevel)
-(define (make-bound-check-get index)
+  (define num-standard-pre-cache 20)))
-  ((@ (system base compile) compile)
-   `(lambda (o) (let ((x (@slot-ref o ,index)))
-                  (if (unbound? x)
-                      (slot-unbound obj)
-                      x)))
-   #:env *goops-module*))
 
-(define (make-get index)
+(define-macro (define-standard-accessor-method form . body)
-  ((@ (system base compile) compile)
+  (let ((name (caar form))
-   `(lambda (o) (@slot-ref o ,index))
+        (n-var (cadar form))
-   #:env *goops-module*))
+        (args (cdr form)))
+    (define (make-one x)
+      (define (body-trans form)
+        (cond ((not (pair? form)) form)
+              ((eq? (car form) '@slot-ref)
+               `(,(car form) ,(cadr form) ,x))
+              ((eq? (car form) '@slot-set!)
+               `(,(car form) ,(cadr form) ,x ,(cadddr form)))
+              (else
+               (map body-trans form))))
+      `(lambda ,args ,@(map body-trans body)))
+    `(define ,name
+       (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
+         (lambda (n)
+           (if (< n ,num-standard-pre-cache)
+               (vector-ref cache n)
+               ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
 
-(define (make-set index)
+(define-standard-accessor-method ((bound-check-get n) o)
-  ((@ (system base compile) compile)
+  (let ((x (@slot-ref o n)))
-   `(lambda (o v) (@slot-set! o ,index v))
+    (if (unbound? x)
-   #:env *goops-module*))
+        (slot-unbound obj)
+        x)))
 
-(define bound-check-get
+(define-standard-accessor-method ((standard-get n) o)
-  (standard-accessor-method make-bound-check-get bound-check-get-methods))
+  (@slot-ref o n))
-(define standard-get (standard-accessor-method make-get standard-get-methods))
+
-(define standard-set (standard-accessor-method make-set standard-set-methods))
+(define-standard-accessor-method ((standard-set n) o v)
+  (@slot-set! o n v))
 
 ;;; compute-getters-n-setters
 ;;;