# 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.
