From 36bdda119860183260b1e17c86ba507113903b42 Mon Sep 17 00:00:00 2001
From: "Guillermo J. Rozas" <edu/mit/csail/zurich/gjr>
Date: Fri, 4 Dec 1987 06:17:32 +0000
Subject: [PATCH] Get the compiler ready for "lexpr" primitives.

---
 .../compiler/machines/bobcat/make.scm-68040   |  6 +--
 v7/src/compiler/machines/bobcat/rules3.scm    | 49 ++++++++++++-------
 2 files changed, 33 insertions(+), 22 deletions(-)

diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index b60b39cdc..eb85635f4 100644
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.45 1987/11/21 18:47:39 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.46 1987/12/04 06:17:32 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -46,11 +46,11 @@ MIT in each case. |#
     (make-environment
       (define :name "Liar (Bobcat 68020)")
       (define :version 3)
-      (define :modification 3)
+      (define :modification 4)
       (define :files)
 
 ;      (parse-rcs-header
-;       "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.45 1987/11/21 18:47:39 jinx Exp $"
+;       "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.46 1987/12/04 06:17:32 jinx Exp $"
 ;       (lambda (filename version date time zone author state)
 ;	 (set! :version (car version))
 ;	 (set! :modification (cadr version))))
diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm
index 17a0f5180..f6d9ab495 100644
--- a/v7/src/compiler/machines/bobcat/rules3.scm
+++ b/v7/src/compiler/machines/bobcat/rules3.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.16 1987/11/21 18:46:28 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.17 1987/12/04 06:16:41 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -36,6 +36,13 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
+(define-rule statement
+  (RETURN)
+  (disable-frame-pointer-offset!
+   (LAP ,@(clear-map!)
+	(CLR B (@A 7))
+	(RTS))))
+
 ;;;; Invocations
 
 (define-rule statement
@@ -101,17 +108,6 @@ MIT in each case. |#
 	  ,(load-dnw frame-size 0)
 	  (JMP ,entry:compiler-lookup-apply)))))
 
-(define-rule statement
-  (INVOCATION:PRIMITIVE (? frame-size) (? prefix) (? continuation)
-			(? primitive))
-  (disable-frame-pointer-offset!
-   (LAP ,@(generate-invocation-prefix prefix '())
-	,@(if (eq? primitive compiled-error-procedure)
-	      (LAP ,(load-dnw frame-size 0)
-		   (JMP ,entry:compiler-error))
-	      (LAP (MOV L (@PCR ,(constant->label primitive)) (D 6))
-		   (JMP ,entry:compiler-primitive-apply))))))
-
 (define-rule statement
   (INVOCATION:UUO-LINK (? frame-size) (? prefix) (? continuation) (? name))
   (disable-frame-pointer-offset!
@@ -126,6 +122,28 @@ MIT in each case. |#
 	(MOV L (D 1) (A 0))
 	(JMP (@A 0)))))
 
+(define-rule statement
+  (INVOCATION:PRIMITIVE (? frame-size) (? prefix) (? continuation)
+			(? primitive))
+  (disable-frame-pointer-offset!
+   (LAP ,@(generate-invocation-prefix prefix '())
+	,@(let ((arity (primitive-procedure-arity primitive)))
+	    (cond ((eq? primitive compiled-error-procedure)
+		   (LAP ,(load-dnw frame-size 0)
+			(JMP ,entry:compiler-error)))
+		  ((not (negative? arity))
+		   (LAP (MOV L (@PCR ,(constant->label primitive)) (D 6))
+			(JMP ,entry:compiler-primitive-apply)))
+		  ((= arity -1)
+		   (LAP (MOV L (& ,frame-size) ,reg:lexpr-primitive-arity)
+			(MOV L (@PCR ,(constant->label primitive)) (D 6))
+			(JMP ,entry:compiler-primitive-apply)))
+		  (else
+		   ;; Unknown primitive arity.  Go through apply.
+		   (LAP ,(load-dnw frame-size 0)
+			(MOV L (@PCR ,(constant->label primitive)) (@-A 7))
+			(JMP ,entry:compiler-apply))))))))
+
 (let-syntax
     ((define-special-primitive-invocation
        (macro (name)
@@ -152,13 +170,6 @@ MIT in each case. |#
   (define-special-primitive-invocation zero?)
   (define-special-primitive-invocation positive?)
   (define-special-primitive-invocation negative?))
-
-(define-rule statement
-  (RETURN)
-  (disable-frame-pointer-offset!
-   (LAP ,@(clear-map!)
-	(CLR B (@A 7))
-	(RTS))))
 
 (define (generate-invocation-prefix prefix needed-registers)
   (let ((clear-map (clear-map!)))
-- 
2.25.1