# New Ticket Created by  Andreas Rottmann 
# Please include the string:  [perl #52666]
# in the subject line of all future correspondence about this issue. 
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=52666 >



Well, the subject sais it all. For implementing EQ? efficiently (using
the `issame' instruction), the compiler now emits `get_root_global'
instructions to access the boolean and empty list values, and those
are initialized when the program is loaded.

Implement equality primitives

From: Andreas Rottmann <[EMAIL PROTECTED]>


---

 MANIFEST                         |    2 +
 languages/eclectus/compiler.scm  |   83 ++++++++++++++++++++++++++++----------
 languages/eclectus/t/equality.pl |    5 ++
 languages/eclectus/t/equality.t  |   15 +++++++
 4 files changed, 84 insertions(+), 21 deletions(-)
 create mode 100644 languages/eclectus/t/equality.pl
 create mode 100644 languages/eclectus/t/equality.t


diff --git a/MANIFEST b/MANIFEST
index 5a50f1f..4827a78 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1324,6 +1324,8 @@ languages/eclectus/t/conditionals.pl                        [eclectus]
 languages/eclectus/t/conditionals.t                         [eclectus]
 languages/eclectus/t/empty_list.pl                          [eclectus]
 languages/eclectus/t/empty_list.t                           [eclectus]
+languages/eclectus/t/equality.pl                            [eclectus]
+languages/eclectus/t/equality.t                             [eclectus]
 languages/eclectus/t/harness                                [eclectus]
 languages/eclectus/t/integers.pl                            [eclectus]
 languages/eclectus/t/integers.t                             [eclectus]
diff --git a/languages/eclectus/compiler.scm b/languages/eclectus/compiler.scm
index 2fee04e..fbb7295 100644
--- a/languages/eclectus/compiler.scm
+++ b/languages/eclectus/compiler.scm
@@ -63,7 +63,6 @@
               $P0 = split ' ', 'post pir evalpmc'
               past_compiler.'stages'( $P0 )
               past_compiler.'eval'(stmts)
-          
           .end
           ")))
 
@@ -71,6 +70,16 @@
 (define emit-builtins
   (lambda ()
     (emit "
+          .sub '__initconst' :init
+              $P0 = new 'EclectusBoolean'
+              $P0 = 1
+              set_root_global ['_eclectus'], '#t', $P0
+              $P0 = new 'EclectusBoolean'
+              set_root_global ['_eclectus'], '#f', $P0
+              $P0 = new 'EclectusEmptyList'
+              set_root_global ['_eclectus'], '()', $P0
+          .end
+
           .sub 'say'
               .param pmc args :slurpy
               if null args goto end
@@ -127,6 +136,29 @@
               .return ($I0)
           .end
 
+          .sub 'eq?'
+              .param pmc a
+              .param pmc b
+              $I0 = issame a, b
+
+              .return ($I0)
+          .end
+
+          .sub 'eqv?'
+              .param pmc a
+              .param pmc b
+              $I0 = iseq a, b
+
+              .return ($I0)
+          .end
+
+          .sub 'equal?'
+              .param pmc a
+              .param pmc b
+              $I0 = iseq a, b
+
+              .return ($I0)
+          .end
           ")))
 
 ; recognition of forms
@@ -308,7 +340,14 @@
 (define-primitive (fx> arg1 arg2)
   (emit-comparison "infix:>" arg1 arg2))
 
+(define-primitive (eq? arg1 arg2)
+  (emit-comparison "eq?" arg1 arg2))
+
+(define-primitive (eqv? arg1 arg2)
+  (emit-comparison "eqv?" arg1 arg2))
 
+(define-primitive (equal? arg1 arg2)
+  (emit-comparison "equal?" arg1 arg2))
 
 ; asking for the type of an object
 (define emit-typequery
@@ -371,26 +410,28 @@
                  (viviself "Undef"))))
 
 (define (emit-constant x)
-  (past::val
-   (cond
-    ((fixnum? x)
-     (quasiquote (@ (value (unquote x))
-                    (returns "EclectusFixnum"))))
-    ((char? x)
-     (quasiquote (@ (value (unquote (char->integer x)))
-                    (returns "EclectusCharacter"))))
-    ((null? x)
-     '(@ (value 0)
-         (returns "EclectusEmptyList")))
-    ((boolean? x)
-     (quasiquote (@ (value (unquote (if x 1 0)))
-                    (returns "EclectusBoolean"))))    
-    ((string? x)
-     (quasiquote (@ (value (unquote (format #f "'~a'" x)))
-                    (returns "EclectusString"))))
-    ((vector? x)
-     (quasiquote (@ (value "'#0()'")
-                    (returns "EclectusString")))))))
+  (cond
+   ((fixnum? x)
+    (past::val `(@ (value ,x)
+                   (returns "EclectusFixnum"))))
+   ((char? x)
+    (past::val `(@ (value ,(char->integer x))
+                   (returns "EclectusCharacter"))))
+   ((null? x)
+    (emit-global-ref "()"))
+   ((boolean? x)
+    (emit-global-ref (if x "#t" "#f")))
+   ((string? x)
+    (past::val `(@ (value (unquote (format #f "'~a'" x)))
+                   (returns "EclectusString"))))
+   ((vector? x)
+    (past::val '(@ (value "'#0()'")
+                   (returns "EclectusString"))))))
+
+
+(define (emit-global-ref name)
+  (past::op `(@ (pasttype "inline")
+                (inline ,(format #f "%r = get_root_global ['_eclectus'], '~a'" name)))))
 
 (define bindings
   (lambda (x)
diff --git a/languages/eclectus/t/equality.pl b/languages/eclectus/t/equality.pl
new file mode 100644
index 0000000..bae4864
--- /dev/null
+++ b/languages/eclectus/t/equality.pl
@@ -0,0 +1,5 @@
+#!/usr/bin/env perl
+
+# $Id$
+
+do 'eclectus/test-wrapper.pl';
diff --git a/languages/eclectus/t/equality.t b/languages/eclectus/t/equality.t
new file mode 100644
index 0000000..9dd3510
--- /dev/null
+++ b/languages/eclectus/t/equality.t
@@ -0,0 +1,15 @@
+; $Id$
+
+(load "tests-driver.scm") ; this should come first
+
+(add-tests-with-string-output "equality"
+  ((eq? #t #t)   => "#t\n")
+  ((eq? #t #f)   => "#f\n")
+  ((eq? '() '()) => "#t\n")
+
+  ((eqv? #\A #\A) => "#t\n")
+  ((eqv? 42 42)   => "#t\n")
+)
+
+(load "compiler.scm")
+(test-all)
Regards, Rotty
-- 
Andreas Rottmann         | [EMAIL PROTECTED]      | [EMAIL PROTECTED] | [EMAIL 
PROTECTED]
http://rotty.uttx.net    | GnuPG Key: http://rotty.uttx.net/gpg.asc
Fingerprint              | C38A 39C5 16D7 B69F 33A3  6993 22C8 27F7 35A9 92E7
v2sw7MYChw5pr5OFma7u7Lw2m5g/l7Di6e6t5BSb7en6g3/5HZa2Xs6MSr1/2p7 hackerkey.com

Python is executable pseudocode, Perl is executable line-noise.

Reply via email to