Adapt visit-prompt-control-flow to use intsets.

[bpt/guile.git] / module / oop / goops.scm

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index eb2b67c..0376d9e 100644 (file)
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc.
 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -134,19 +134,18 @@
 
 (define *goops-module* (current-module))
 
+;; XXX FIXME: figure out why the 'eval-when's in this file must use
+;; 'compile' and must avoid 'expand', but only in 2.2, and only when
+;; compiling something that imports goops, e.g. (ice-9 occam-channel),
+;; before (oop goops) itself has been compiled.
+
 ;; First initialize the builtin part of GOOPS
-(eval-when (eval load compile)
+(eval-when (compile load eval)
   (%init-goops-builtins))
 
-(eval-when (eval load compile)
+(eval-when (compile load eval)
   (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
-  (add-interesting-primitive! 'class-of)
-  (define (@slot-ref o n)
-    (struct-ref o n))
-  (define (@slot-set! o n v)
-    (struct-set! o n v))
-  (add-interesting-primitive! '@slot-ref)
-  (add-interesting-primitive! '@slot-set!))
+  (add-interesting-primitive! 'class-of))
 
 ;; Then load the rest of GOOPS
 (use-modules (oop goops util)
@@ -155,7 +154,7 @@
 
 \f
 ;; FIXME: deprecate.
-(eval-when (eval load compile)
+(eval-when (compile load eval)
   (define min-fixnum (- (expt 2 29)))
   (define max-fixnum (- (expt 2 29) 1)))
 
@@ -1193,44 +1192,34 @@
 (define (make-generic-bound-check-getter proc)
   (lambda (o) (assert-bound (proc o) o)))
 
-;; the idea is to compile the index into the procedure, for fastest
-;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
-
-(eval-when (eval load compile)
-  (define num-standard-pre-cache 20))
-
-(define-macro (define-standard-accessor-method form . body)
-  (let ((name (caar form))
-        (n-var (cadar form))
-        (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)))))))
+;;; Pre-generate getters and setters for the first 20 slots.
+(define-syntax define-standard-accessor-method
+  (lambda (stx)
+    (define num-standard-pre-cache 20)
+    (syntax-case stx ()
+      ((_ ((proc n) arg ...) body)
+       #`(define proc
+           (let ((cache (vector #,@(map (lambda (n*)
+                                          #`(lambda (arg ...)
+                                              (let ((n #,n*))
+                                                body)))
+                                        (iota num-standard-pre-cache)))))
+             (lambda (n)
+               (if (< n #,num-standard-pre-cache)
+                   (vector-ref cache n)
+                   (lambda (arg ...) body)))))))))
 
 (define-standard-accessor-method ((bound-check-get n) o)
-  (let ((x (@slot-ref o n)))
+  (let ((x (struct-ref o n)))
     (if (unbound? x)
         (slot-unbound o)
         x)))
 
 (define-standard-accessor-method ((standard-get n) o)
-  (@slot-ref o n))
+  (struct-ref o n))
 
 (define-standard-accessor-method ((standard-set n) o v)
-  (@slot-set! o n v))
+  (struct-set! o n v))
 
 ;;; compute-getters-n-setters
 ;;;