From 95de44cd3d57900db1cc2e4ff9d6240713ac89bb Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 14 May 2018 21:48:25 -0700 Subject: [PATCH] Change users of arity-dispatched-procedure to use the abstraction. --- src/runtime/apply.scm | 23 ++++++------ src/runtime/arith.scm | 78 ++++++++++++++++++----------------------- src/runtime/runtime.pkg | 3 +- 3 files changed, 47 insertions(+), 57 deletions(-) diff --git a/src/runtime/apply.scm b/src/runtime/apply.scm index 19e8802ca..2e4dfb37e 100644 --- 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 6ca9e1de2..96ce59b05 100644 --- 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 &/)) @@ -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 5eb537305..b50141fcf 100644 --- 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") -- 2.25.1