# New Ticket Created by Andreas Rottmann
# Please include the string: [perl #52600]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=52600 >
The attached patch fixes several non-R5RS-isms and adds support for
running the testsuite with GNU Guile (tested with 1.8.4).
MANIFEST | 1
languages/eclectus/compiler.scm | 38 +++++++++---------------
languages/eclectus/guile/prelude.scm | 51 +++++++++++++++++++++++++++++++++
languages/eclectus/t/harness | 7 ++--
languages/eclectus/t/learning_scheme.t | 15 +--------
languages/eclectus/tests-driver.scm | 12 +++----
6 files changed, 79 insertions(+), 45 deletions(-)
Replace usage of putprop/getprop with a hash table, plus various tweaks
From: Andreas Rottmann <[EMAIL PROTECTED]>
to make the testsuite run with guile, too.
---
MANIFEST | 1 +
languages/eclectus/compiler.scm | 38 +++++++++---------------
languages/eclectus/guile/prelude.scm | 51 ++++++++++++++++++++++++++++++++
languages/eclectus/t/harness | 7 +++-
languages/eclectus/t/learning_scheme.t | 15 ++-------
languages/eclectus/tests-driver.scm | 12 ++++----
6 files changed, 79 insertions(+), 45 deletions(-)
create mode 100644 languages/eclectus/guile/prelude.scm
diff --git a/MANIFEST b/MANIFEST
index 3a3f8dc..32b584c 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1311,6 +1311,7 @@ languages/eclectus/src/pmc/eclectuspair.pmc [eclectus]
languages/eclectus/src/pmc/eclectusstring.pmc [eclectus]
languages/eclectus/src/pmc/eclectusvector.pmc [eclectus]
languages/eclectus/test-wrapper.pl [eclectus]
+languages/eclectus/guile/prelude.scm [eclectus]
languages/eclectus/t/binary_primitives.pl [eclectus]
languages/eclectus/t/binary_primitives.t [eclectus]
languages/eclectus/t/booleans.pl [eclectus]
diff --git a/languages/eclectus/compiler.scm b/languages/eclectus/compiler.scm
index c48e662..e7eeb85 100644
--- a/languages/eclectus/compiler.scm
+++ b/languages/eclectus/compiler.scm
@@ -159,32 +159,27 @@
; Support for primitive functions
-; is x a primitive?
-(define primitive?
- (lambda (x)
- (and (symbol? x)
- (getprop x '*is-prim*))))
+(define-record primitive (arg-count emitter))
+
+(define *primitives* (make-eq-hashtable))
+
+(define (lookup-primitive sym)
+ (hashtable-ref *primitives* sym #f))
; is x a call to a primitive?
(define primcall?
(lambda (x)
- (and (pair? x)
- (primitive? (car x)))))
+ (and (pair? x) (lookup-primitive (car x)))))
-; a primitive function is a symbol with the properties
-; *is-prim*, *arg-count* and *emitter*
; implementatus of primitive functions are added
; with 'define-primitive'
(define-syntax define-primitive
(syntax-rules ()
((_ (prim-name arg* ...) b b* ...)
- (begin
- (putprop 'prim-name '*is-prim*
- #t)
- (putprop 'prim-name '*arg-count*
- (length '(arg* ...)))
- (putprop 'prim-name '*emitter*
- (lambda (arg* ...) b b* ...))))))
+ (hashtable-set! *primitives*
+ 'prim-name
+ (make-primitive (length '(arg* ...))
+ (lambda (arg* ...) b b* ...))))))
; implementation of fxadd1
(define-primitive (fxadd1 arg)
@@ -319,7 +314,7 @@
'(@ (pasttype "if"))
(past::op
(quasiquote (@ (pasttype "inline")
- (inline (unquote (format "new %r, 'EclectusBoolean'\\nisa $I1, %0, '~a'\\n %r = $I1" typename)))))
+ (inline (unquote (format #f "new %r, 'EclectusBoolean'\\nisa $I1, %0, '~a'\\n %r = $I1" typename)))))
(emit-expr arg))
(emit-expr #t)
(emit-expr #f))))
@@ -341,11 +336,6 @@
-; a getter of '*emitter*'
-(define primitive-emitter
- (lambda (x)
- (getprop x '*emitter*)))
-
(define emit-function-header
(lambda (function-name)
(emit (string-append ".sub " function-name))))
@@ -359,7 +349,7 @@
(define emit-primcall
(lambda (x)
- (let ((prim (car x)) (args (cdr x)))
+ (let ((prim (lookup-primitive (car x))) (args (cdr x)))
(apply (primitive-emitter prim) args))))
(define emit-functional-application
@@ -395,7 +385,7 @@
(scope "lexical")
(viviself "Undef"))))
((string? x)
- (quasiquote (@ (value (unquote (format "'~a'" x)))
+ (quasiquote (@ (value (unquote (format #f "'~a'" x)))
(returns "EclectusString"))))
((vector? x)
(quasiquote (@ (value "'#0()'")
diff --git a/languages/eclectus/guile/prelude.scm b/languages/eclectus/guile/prelude.scm
new file mode 100644
index 0000000..b7b750f
--- /dev/null
+++ b/languages/eclectus/guile/prelude.scm
@@ -0,0 +1,51 @@
+(use-modules (ice-9 syncase)
+ (srfi srfi-39)
+ (srfi srfi-9))
+
+(define (load filename)
+ (primitive-load filename))
+
+(define-syntax unless
+ (syntax-rules ()
+ ((unless condition body1 body ...)
+ (if (not condition)
+ (begin body1 body ...)))))
+
+(define-macro (define-record name fields)
+ (define (symbol-append . symbols)
+ (string->symbol (apply string-append (map symbol->string symbols))))
+ `(define-record-type name
+ (,(symbol-append 'make- name) ,@fields)
+ ,(symbol-append name '?)
+ ,@(map (lambda (field)
+ `(,field ,(symbol-append name '- field)))
+ fields)))
+
+(define (make-eq-hashtable)
+ (make-hash-table))
+
+(define (hashtable-ref tbl key default)
+ (hashq-ref tbl key default))
+
+(define (hashtable-set! tbl key value)
+ (hashq-set! tbl key value))
+
+(define (printf fmt . args)
+ (apply format #t fmt args))
+
+(define (fprintf port fmt . args)
+ (apply format port fmt args))
+
+(define (flush-output-port . port-opt)
+ (apply force-output port-opt))
+
+(define (open-output-file filename mode)
+ (open-file filename (case mode
+ ((replace) "w")
+ (else (error "invalid file mode" mode)))))
+
+(define (atom? x)
+ (not (pair? x)))
+
+(define (fixnum? x)
+ (integer? x)) ;; FIXME: This is a gross approximation
diff --git a/languages/eclectus/t/harness b/languages/eclectus/t/harness
index 27fd747..4f93a6a 100644
--- a/languages/eclectus/t/harness
+++ b/languages/eclectus/t/harness
@@ -29,9 +29,10 @@ use 5.008;
use lib qw( ../lib ../../lib ../../lib );
use Parrot::Test::Harness
- language => 'eclectus',
- exec => [ 'petite', '--script' ],
- files => [ 't/*.pl' ];
+ language => 'eclectus',
+ exec => [ 'petite', '--script' ],
+ #exec => [ 'guile', '--debug', '-l', 'guile/prelude.scm', '-s' ],
+ files => [ 't/*.pl' ];
=head1 SEE ALSO
diff --git a/languages/eclectus/t/learning_scheme.t b/languages/eclectus/t/learning_scheme.t
index 9a7b2b7..4b82f34 100644
--- a/languages/eclectus/t/learning_scheme.t
+++ b/languages/eclectus/t/learning_scheme.t
@@ -6,25 +6,16 @@
; It is just a playgroud for trying out Scheme syntax
; set up TAP test plan
-(plan 17)
+(plan 15)
(define test-num 1)
(pass test-num "form definition")
-; object properties are something like Perl hashes
-(putprop 'parrot 'wing "feather")
-
-(define desc "getprop equals")
-(set! test-num (add1 test-num))
-(if (string=? (getprop 'parrot 'wing) "feather") (pass test-num desc) (fail test-num desc))
-
-(define desc "getprop not equal")
-(set! test-num (add1 test-num))
-(if (string=? (getprop 'parrot 'wing) "not a feather") (fail test-num desc) (pass test-num desc))
-
; and
(define desc "and")
+(define (add1 x) (+ x 1))
+
(set! test-num (add1 test-num))
( if (and #t #t) (pass test-num desc) (fail test-num desc))
diff --git a/languages/eclectus/tests-driver.scm b/languages/eclectus/tests-driver.scm
index 43673a5..b42837e 100644
--- a/languages/eclectus/tests-driver.scm
+++ b/languages/eclectus/tests-driver.scm
@@ -40,7 +40,7 @@
((null? tests) (f i ls))
(else
(test-one i (car tests) test-name)
- (g (add1 i) (cdr tests))))))))))
+ (g (+ i 1) (cdr tests))))))))))
(define compile-port
(make-parameter
@@ -60,15 +60,15 @@
; TODO: can I use (directory-separator) in petite?
(define *path-to-parrot*
- (if (fxzero? (system "perl -e \"exit($^O eq q{MSWin32} ? 1 : 0)\""))
+ (if (zero? (system "perl -e \"exit($^O eq q{MSWin32} ? 1 : 0)\""))
"../../parrot"
"..\\..\\parrot"))
(define (execute)
(if run-with-petite
- (unless (fxzero? (system "petite --script stst.scm > stst.out"))
+ (unless (zero? (system "petite --script stst.scm > stst.out"))
(error 'execute "produced program exited abnormally"))
- (unless (fxzero? (system (string-append *path-to-parrot* " stst.pir > stst.out")))
+ (unless (zero? (system (string-append *path-to-parrot* " stst.pir > stst.out")))
(error 'execute "produced program exited abnormally"))))
(define (get-string)
@@ -86,8 +86,8 @@
(run-compile expr)
(execute)
(if (string=? expected-output (get-string))
- (pass ( + test-id 1 ) (format "~a: ~a" test-name expr))
- (fail ( + test-id 1 ) (format "~a: expected ~s, got ~a" test-name expr (get-string) ))))
+ (pass ( + test-id 1 ) (format #f "~a: ~a" test-name expr))
+ (fail ( + test-id 1 ) (format #f "~a: expected ~s, got ~a" test-name expr (get-string) ))))
(define (emit . args)
(apply fprintf (compile-port) args)
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
Could Jesus microwave a burrito so hot that he himself couldn't eat it? - Homer
S.
