Allow specification of arity for the INTEGRATE-PRIMITIVE-PROCEDURES

declaration.

diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm
index 1b6c8cfa7812fb4bafac38992839c3fd78acbe81..77878b2a61f4d058d3dbd4035f7e11710950df13 100644 (file)
--- a/v7/src/sf/make.scm
+++ b/v7/src/sf/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.12 1990/06/11 16:34:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.13 1990/06/13 22:20:02 jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -39,4 +39,4 @@ MIT in each case. |#
 (package/system-loader "sf" '() 'QUERY)
 ((package/reference (find-package '(SCODE-OPTIMIZER))
                    'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 12 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 13 '()))
\ No newline at end of file

diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm
index 5166dde5d1f807f7dea99b6ea7eac0a8ead16f47..3afd1d7079e5518c38a55459354f5db7b92ee333 100644 (file)
--- a/v7/src/sf/pardec.scm
+++ b/v7/src/sf/pardec.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 4.2 1988/10/30 14:31:20 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 4.3 1990/06/13 22:19:38 jinx Rel $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -238,22 +238,48 @@ MIT in each case. |#
                        (values (cons name names) (cons value vals)))))))))
       (lambda (names vals)
        (bind/values table/cons table 'INTEGRATE true names vals)))))
+\f
+#|
+The following are allowed:
+
+symbol                         ; obvious.
+(symbol)                       ; obvious.
+(symbol1 symbol2)              ; use symbol1 for primitive named symbol2.
+(symbol number)                        ; primitive symbol has arity number.
+(symbol1 symbol2 number)       ; use symbol1 for primitive named symbol2
+                               ;   with arity number.
+
+|#
 
 (define (parse-primitive-specification block specification)
   block                                        ;ignored
-  (let ((finish
-        (lambda (variable-name primitive-name)
+  (let ((fail
+        (lambda ()
+          (error "Bad primitive specification" specification)))
+       (finish
+        (lambda (variable-name arguments)
           (values variable-name
                   (constant->integration-info
-                   (make-primitive-procedure primitive-name))))))
-    (cond ((and (pair? specification)
-               (symbol? (car specification))
-               (pair? (cdr specification))
-               (symbol? (cadr specification))
-               (null? (cddr specification)))
-          (finish (first specification) (second specification)))
-         ((symbol? specification) (finish specification specification))
-         (else (error "Bad primitive specification" specification)))))
+                   (apply make-primitive-procedure arguments))))))
+    (cond ((symbol? specification)
+          (finish specification (list specification)))
+         ((or (not (pair? specification))
+              (not (symbol? (car specification))))
+          (fail))
+         ((null? (cdr specification))
+          (finish (car specification) specification))
+         ((not (null? (cddr specification)))
+          (if (and (null? (cdddr specification))
+                   (symbol? (cadr specification))
+                   (number? (caddr specification)))
+              (finish (car specification) (cdr specification))
+              (fail)))
+         ((symbol? (cadr specification))
+          (finish (car specification) (cdr specification)))
+         ((number? (cadr specification))
+          (finish (car specification) specification))
+         (else
+          (fail)))))
 \f
 ;;; Special declarations courtesy JRM
 ;;; I return the operations table unmodified, but bash on the

diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm
index 77906c077f4859a7595c3349a177172a67ff1cf6..b1f994194dc82d5c1b9e418fa4839a2f527cf8bf 100644 (file)
--- a/v8/src/sf/make.scm
+++ b/v8/src/sf/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.12 1990/06/11 16:34:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.13 1990/06/13 22:20:02 jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -39,4 +39,4 @@ MIT in each case. |#
 (package/system-loader "sf" '() 'QUERY)
 ((package/reference (find-package '(SCODE-OPTIMIZER))
                    'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 12 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 13 '()))
\ No newline at end of file