From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Sun, 17 Sep 2006 12:10:04 +0000 (+0000)
Subject: 1. Add unsigned fixnum comparisons, needed to compile runtime-check.
X-Git-Tag: 20090517-FFI~935
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c5efb28f627ff9c96c00a0f3e08288719a25ca83;p=mit-scheme.git

1. Add unsigned fixnum comparisons, needed to compile runtime-check.

2. C back end:
   Eliminate use of the 'system' primitive and use run-shell-command
   from option synchronous-subprocess.
---

diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm
index 080bab934..509b7314d 100644
--- a/v7/src/compiler/machines/C/ctop.scm
+++ b/v7/src/compiler/machines/C/ctop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ctop.scm,v 1.16 2006/09/16 11:19:09 gjr Exp $
+$Id: ctop.scm,v 1.17 2006/09/17 12:10:04 gjr Exp $
 
 Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
 
@@ -143,8 +143,8 @@ USA.
 		   (write-string ";Executing \"")
 		   (write-string command-line)
 		   (write-string "\"")))
-	     (let ((result ((ucode-primitive system) command-line)))
-					#|
+	     (let ((result (run-shell-command command-line)))
+	       #|
 	       ;; Some C compilers always fail
 	       (if (not (zero? result))
 		   (error "compiler: C compiler/linker failed"))
diff --git a/v7/src/compiler/machines/C/lapgen.scm b/v7/src/compiler/machines/C/lapgen.scm
index f9354e3bc..6c3ce422f 100644
--- a/v7/src/compiler/machines/C/lapgen.scm
+++ b/v7/src/compiler/machines/C/lapgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: lapgen.scm,v 1.18 2006/09/16 11:19:09 gjr Exp $
+$Id: lapgen.scm,v 1.19 2006/09/17 12:10:04 gjr Exp $
 
 Copyright 1993,1998,2001,2002,2004,2006 Massachusetts Institute of Technology
 
@@ -565,6 +565,16 @@ USA.
    (lambda (label)
      (LAP "if (!(" ,val1 ,cc ,val2 "))\n\t  goto " ,label ";\n\t")))
   (LAP))
+
+(define (compare/unsigned cc val1 val2)
+  (set-current-branches!
+   (lambda (label)
+     (LAP "if (((unsigned long) " ,val1 ")"
+	  ,cc "((unsigned long) " ,val2 "))\n\t  goto " ,label ";\n\t"))
+   (lambda (label)
+     (LAP "if (!(((unsigned long) " ,val1 ")"
+	  ,cc "((unsigned long) " ,val2 ")))\n\t  goto " ,label ";\n\t")))
+  (LAP))
 
 (define (define-arithmetic-method operator methods method)
   (let ((entry (assq operator (cdr methods))))
diff --git a/v7/src/compiler/machines/C/make.scm b/v7/src/compiler/machines/C/make.scm
index a8446c8c5..49c39f0ac 100644
--- a/v7/src/compiler/machines/C/make.scm
+++ b/v7/src/compiler/machines/C/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 1.6 2006/09/16 11:19:09 gjr Exp $
+$Id: make.scm,v 1.7 2006/09/17 12:10:04 gjr Exp $
 
 Copyright (c) 1992, 1999, 2006 Massachusetts Institute of Technology
 
@@ -27,6 +27,8 @@ USA.
 
 (declare (usual-integrations))
 
+(load-option 'synchronous-subprocess)
+
 (begin
   (declare-shared-library "sf+compiler" (lambda () true))
   (let ((value ((load "base/make")
diff --git a/v7/src/compiler/machines/C/rulfix.scm b/v7/src/compiler/machines/C/rulfix.scm
index dc809b51d..c9d0c813d 100644
--- a/v7/src/compiler/machines/C/rulfix.scm
+++ b/v7/src/compiler/machines/C/rulfix.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rulfix.scm,v 1.7 2003/02/14 18:28:02 cph Exp $
+$Id: rulfix.scm,v 1.8 2006/09/17 12:10:04 gjr Exp $
 
-Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2001, 2002, 2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -466,31 +466,40 @@ USA.
   (FIXNUM-PRED-2-ARGS (? predicate)
 		      (REGISTER (? source1))
 		      (REGISTER (? source2)))
-  (compare (fixnum-pred-2->cc predicate)
-	   (standard-source! source1 'LONG)
-	   (standard-source! source2 'LONG)))
+  ((comparator predicate)
+   (fixnum-pred-2->cc predicate)
+   (standard-source! source1 'LONG)
+   (standard-source! source2 'LONG)))
 
 (define-rule predicate
   (FIXNUM-PRED-2-ARGS (? predicate)
 		      (REGISTER (? source))
 		      (OBJECT->FIXNUM (CONSTANT (? constant))))
-  (compare (fixnum-pred-2->cc predicate)
-	   (standard-source! source 'LONG)
-	   (longify constant)))
+  ((comparator predicate)
+   (fixnum-pred-2->cc predicate)
+   (standard-source! source 'LONG)
+   (longify constant)))
 
 (define-rule predicate
   (FIXNUM-PRED-2-ARGS (? predicate)
 		      (OBJECT->FIXNUM (CONSTANT (? constant)))
 		      (REGISTER (? source)))
-  (compare (fixnum-pred-2->cc predicate)
-	   (longify constant)
-	   (standard-source! source 'LONG)))
+  ((comparator predicate)
+   (fixnum-pred-2->cc predicate)
+   (longify constant)
+   (standard-source! source 'LONG)))
  
+(define-integrable (comparator predicate)
+  (if (memq predicate '(UNSIGNED-LESS-THAN-FIXNUM?
+			UNSIGNED-GREATER-THAN-FIXNUM?))
+      compare/unsigned
+      compare))
+
 (define (fixnum-pred-2->cc predicate)
   (case predicate
     ((EQUAL-FIXNUM?) " == ")
-    ((LESS-THAN-FIXNUM?) " < ")
-    ((GREATER-THAN-FIXNUM?) " > ")
+    ((LESS-THAN-FIXNUM? UNSIGNED-LESS-THAN-FIXNUM?) " < ")
+    ((GREATER-THAN-FIXNUM? UNSIGNED-GREATER-THAN-FIXNUM?) " > ")
     (else
      (error "unknown fixnum predicate" predicate))))