Change users of arity-dispatched-procedure to use the abstraction.

diff --git a/src/runtime/apply.scm b/src/runtime/apply.scm
index 19e8802ca7e6434fee7b62d0efd3482fb04169d7..2e4dfb37ef22fab96ff1a377c8e90aeeff1cbac4 100644 (file)
--- a/src/runtime/apply.scm
+++ b/src/runtime/apply.scm
@@ -33,6 +33,16 @@ USA.
 ;;;  so there is a binary (primitive) version of apply installed
 ;;;  at boot time, and this code replaces it.
 
+(add-boot-init!
+ (lambda ()
+   (set! apply
+        (make-arity-dispatched-procedure
+         apply-entity-procedure
+         (lambda () (error:wrong-number-of-arguments apply '(1 . #f) '()))
+         (lambda (f) (f))
+         apply-2))
+   unspecific))
+
 (define (apply-2 f a0)
   (let ((fail (lambda () (error "apply: Improper argument list" a0))))
     (let-syntax
@@ -92,15 +102,4 @@ USA.
                           (set-cdr! last (car next))))
                     args)
                   (car args))
-              '())))
-
-(define (initialize-package!)
-  (set! apply
-       (make-entity
-        apply-entity-procedure
-        (vector (fixed-objects-item 'arity-dispatcher-tag)
-                (lambda ()
-                  (error:wrong-number-of-arguments apply '(1 . #f) '()))
-                (lambda (f) (f))
-                apply-2)))
-  unspecific)
\ No newline at end of file
+              '())))
\ No newline at end of file

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index 6ca9e1de228e33d5f07055d2932519bba609981b..96ce59b0577d3c1927ff74d7d67dcf4bd1ccabd8 100644 (file)
--- a/src/runtime/arith.scm
+++ b/src/runtime/arith.scm
@@ -148,22 +148,20 @@ USA.
           (let ((name (list-ref form 1))
                 (identity (close-syntax (list-ref form 3) environment)))
             `(set! ,(close-syntax name environment)
-                   (make-entity
+                   (make-arity-dispatched-procedure
                     (named-lambda (,name self . zs)
                       self             ; ignored
                       (reduce ,(close-syntax (list-ref form 2) environment)
                               ,identity
                               zs))
-                    (vector
-                     (fixed-objects-item 'arity-dispatcher-tag)
-                     (named-lambda (,(symbol 'nullary- name))
-                       ,identity)
-                     (named-lambda (,(symbol 'unary- name) z)
-                       (if (not (complex:complex? z))
-                           (error:wrong-type-argument z "number" ',name))
-                       z)
-                     (named-lambda (,(symbol 'binary- name) z1 z2)
-                       ((ucode-primitive ,(list-ref form 4)) z1 z2))))))))))
+                    (named-lambda (,(symbol 'nullary- name))
+                      ,identity)
+                    (named-lambda (,(symbol 'unary- name) z)
+                      (if (not (complex:complex? z))
+                          (error:wrong-type-argument z "number" ',name))
+                      z)
+                    (named-lambda (,(symbol 'binary- name) z1 z2)
+                      ((ucode-primitive ,(list-ref form 4)) z1 z2)))))))))
     (commutative + complex:+ 0 &+)
     (commutative * complex:* 1 &*))
 
@@ -173,7 +171,7 @@ USA.
         (lambda (form environment)
           (let ((name (list-ref form 1)))
             `(set! ,(close-syntax name environment)
-                   (make-entity
+                   (make-arity-dispatched-procedure
                     (named-lambda (,name self z1 . zs)
                       self             ; ignored
                       (,(close-syntax (list-ref form 3) environment)
@@ -181,12 +179,10 @@ USA.
                        (reduce ,(close-syntax (list-ref form 4) environment)
                                ,(close-syntax (list-ref form 5) environment)
                                zs)))
-                    (vector
-                     (fixed-objects-item 'arity-dispatcher-tag)
-                     #f
-                     ,(close-syntax (list-ref form 2) environment)
-                     (named-lambda (,(symbol 'binary- name) z1 z2)
-                       ((ucode-primitive ,(list-ref form 6)) z1 z2))))))))))
+                    #f
+                    ,(close-syntax (list-ref form 2) environment)
+                    (named-lambda (,(symbol 'binary- name) z1 z2)
+                      ((ucode-primitive ,(list-ref form 6)) z1 z2)))))))))
     (non-commutative - complex:negate complex:- complex:+ 0 &-)
     (non-commutative / complex:invert complex:/ complex:* 1 &/))
 \f
@@ -197,27 +193,25 @@ USA.
           (let ((name (list-ref form 1))
                 (type (list-ref form 4)))
             `(set! ,(close-syntax name environment)
-                   (make-entity
+                   (make-arity-dispatched-procedure
                     (named-lambda (,name self . zs)
                       self             ; ignored
                       (reduce-comparator
                        ,(close-syntax (list-ref form 2) environment)
                        zs ',name))
-                    (vector
-                     (fixed-objects-item 'arity-dispatcher-tag)
-                     (named-lambda (,(symbol 'nullary- name)) #t)
-                     (named-lambda (,(symbol 'unary- name) z)
-                       (if (not (,(intern (string-append "complex:" type "?"))
-                                 z))
-                           (error:wrong-type-argument
-                            z ,(string-append type " number") ',name))
-                       #t)
-                     (named-lambda (,(symbol 'binary- name) z1 z2)
-                       ,(let ((p
-                               `((ucode-primitive ,(list-ref form 3)) z1 z2)))
-                          (if (list-ref form 5)
-                              `(not ,p)
-                              p)))))))))))
+                    (named-lambda (,(symbol 'nullary- name)) #t)
+                    (named-lambda (,(symbol 'unary- name) z)
+                      (if (not (,(intern (string-append "complex:" type "?"))
+                                z))
+                          (error:wrong-type-argument
+                           z ,(string-append type " number") ',name))
+                      #t)
+                    (named-lambda (,(symbol 'binary- name) z1 z2)
+                      ,(let ((p
+                              `((ucode-primitive ,(list-ref form 3)) z1 z2)))
+                         (if (list-ref form 5)
+                             `(not ,p)
+                             p))))))))))
     (relational = complex:= &= "complex" #f)
     (relational < complex:< &< "real" #f)
     (relational > complex:> &> "real" #f)
@@ -231,18 +225,16 @@ USA.
           (let ((name (list-ref form 1))
                 (generic-binary (close-syntax (list-ref form 2) environment)))
             `(set! ,(close-syntax name environment)
-                   (make-entity
+                   (make-arity-dispatched-procedure
                     (named-lambda (,name self x . xs)
                       self             ; ignored
                       (reduce-max/min ,generic-binary x xs ',name))
-                    (vector
-                     (fixed-objects-item 'arity-dispatcher-tag)
-                     #f
-                     (named-lambda (,(symbol 'unary- name) x)
-                       (if (not (complex:real? x))
-                           (error:wrong-type-argument x "real number" ',name))
-                       x)
-                     ,generic-binary))))))))
+                    #f
+                    (named-lambda (,(symbol 'unary- name) x)
+                      (if (not (complex:real? x))
+                          (error:wrong-type-argument x "real number" ',name))
+                      x)
+                    ,generic-binary)))))))
     (max/min max complex:max)
     (max/min min complex:min))
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5eb537305488bf9bd11ae0f013d44dacc47a4b46..b50141fcf4d5fb97c9c24694f7e0405493b18711 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1253,8 +1253,7 @@ USA.
 
 (define-package (runtime apply)
   (files "apply")
-  (parent (runtime))
-  (initialization (initialize-package!)))
+  (parent (runtime)))
 
 (define-package (runtime character)
   (files "char")